summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc/Utils
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2020-03-19 10:28:01 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-04-07 18:36:49 -0400
commit255418da5d264fb2758bc70925adb2094f34adc3 (patch)
tree39e3d7f84571e750f2a087c1bc2ab87198e9b147 /compiler/GHC/Tc/Utils
parent3d2991f8b4c1b686323b2c9452ce845a60b8d94c (diff)
downloadhaskell-255418da5d264fb2758bc70925adb2094f34adc3.tar.gz
Modules: type-checker (#13009)
Update Haddock submodule
Diffstat (limited to 'compiler/GHC/Tc/Utils')
-rw-r--r--compiler/GHC/Tc/Utils/Backpack.hs1011
-rw-r--r--compiler/GHC/Tc/Utils/Env.hs1110
-rw-r--r--compiler/GHC/Tc/Utils/Env.hs-boot10
-rw-r--r--compiler/GHC/Tc/Utils/Instantiate.hs852
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs1998
-rw-r--r--compiler/GHC/Tc/Utils/TcMType.hs2419
-rw-r--r--compiler/GHC/Tc/Utils/TcType.hs2489
-rw-r--r--compiler/GHC/Tc/Utils/TcType.hs-boot8
-rw-r--r--compiler/GHC/Tc/Utils/Unify.hs2331
-rw-r--r--compiler/GHC/Tc/Utils/Unify.hs-boot15
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs1919
11 files changed, 14162 insertions, 0 deletions
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
new file mode 100644
index 0000000000..93cb63812c
--- /dev/null
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -0,0 +1,1011 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module GHC.Tc.Utils.Backpack (
+ findExtraSigImports',
+ findExtraSigImports,
+ implicitRequirements',
+ implicitRequirements,
+ checkUnitId,
+ tcRnCheckUnitId,
+ tcRnMergeSignatures,
+ mergeSignatures,
+ tcRnInstantiateSignature,
+ instantiateSignature,
+) where
+
+import GhcPrelude
+
+import GHC.Types.Basic (defaultFixity, TypeOrKind(..))
+import GHC.Driver.Packages
+import GHC.Tc.Gen.Export
+import GHC.Driver.Session
+import GHC.Hs
+import GHC.Types.Name.Reader
+import GHC.Tc.Utils.Monad
+import GHC.Tc.TyCl.Utils
+import GHC.Core.InstEnv
+import GHC.Core.FamInstEnv
+import GHC.Tc.Utils.Instantiate
+import GHC.IfaceToCore
+import GHC.Tc.Utils.TcMType
+import GHC.Tc.Utils.TcType
+import GHC.Tc.Solver
+import GHC.Tc.Types.Constraint
+import GHC.Tc.Types.Origin
+import GHC.Iface.Load
+import GHC.Rename.Names
+import ErrUtils
+import GHC.Types.Id
+import GHC.Types.Module
+import GHC.Types.Name
+import GHC.Types.Name.Env
+import GHC.Types.Name.Set
+import GHC.Types.Avail
+import GHC.Types.SrcLoc
+import GHC.Driver.Types
+import Outputable
+import GHC.Core.Type
+import FastString
+import GHC.Rename.Fixity ( lookupFixityRn )
+import Maybes
+import GHC.Tc.Utils.Env
+import GHC.Types.Var
+import GHC.Iface.Syntax
+import PrelNames
+import qualified Data.Map as Map
+
+import GHC.Driver.Finder
+import GHC.Types.Unique.DSet
+import GHC.Types.Name.Shape
+import GHC.Tc.Errors
+import GHC.Tc.Utils.Unify
+import GHC.Iface.Rename
+import Util
+
+import Control.Monad
+import Data.List (find)
+
+import {-# SOURCE #-} GHC.Tc.Module
+
+#include "HsVersions.h"
+
+fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc
+fixityMisMatch real_thing real_fixity sig_fixity =
+ vcat [ppr real_thing <+> text "has conflicting fixities in the module",
+ text "and its hsig file",
+ text "Main module:" <+> ppr_fix real_fixity,
+ text "Hsig file:" <+> ppr_fix sig_fixity]
+ where
+ ppr_fix f =
+ ppr f <+>
+ (if f == defaultFixity
+ then parens (text "default")
+ else empty)
+
+checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn ()
+checkHsigDeclM sig_iface sig_thing real_thing = do
+ let name = getName real_thing
+ -- TODO: Distinguish between signature merging and signature
+ -- implementation cases.
+ checkBootDeclM False sig_thing real_thing
+ real_fixity <- lookupFixityRn name
+ let sig_fixity = case mi_fix_fn (mi_final_exts sig_iface) (occName name) of
+ Nothing -> defaultFixity
+ Just f -> f
+ when (real_fixity /= sig_fixity) $
+ addErrAt (nameSrcSpan name)
+ (fixityMisMatch real_thing real_fixity sig_fixity)
+
+-- | Given a 'ModDetails' of an instantiated signature (note that the
+-- 'ModDetails' must be knot-tied consistently with the actual implementation)
+-- and a 'GlobalRdrEnv' constructed from the implementor of this interface,
+-- verify that the actual implementation actually matches the original
+-- interface.
+--
+-- Note that it is already assumed that the implementation *exports*
+-- a sufficient set of entities, since otherwise the renaming and then
+-- typechecking of the signature 'ModIface' would have failed.
+checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn ()
+checkHsigIface tcg_env gr sig_iface
+ ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts,
+ md_types = sig_type_env, md_exports = sig_exports } = do
+ traceTc "checkHsigIface" $ vcat
+ [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ]
+ mapM_ check_export (map availName sig_exports)
+ unless (null sig_fam_insts) $
+ panic ("GHC.Tc.Module.checkHsigIface: Cannot handle family " ++
+ "instances in hsig files yet...")
+ -- Delete instances so we don't look them up when
+ -- checking instance satisfiability
+ -- TODO: this should not be necessary
+ tcg_env <- getGblEnv
+ setGblEnv tcg_env { tcg_inst_env = emptyInstEnv,
+ tcg_fam_inst_env = emptyFamInstEnv,
+ tcg_insts = [],
+ tcg_fam_insts = [] } $ do
+ mapM_ check_inst sig_insts
+ failIfErrsM
+ where
+ -- NB: the Names in sig_type_env are bogus. Let's say we have H.hsig
+ -- in package p that defines T; and we implement with himpl:H. Then the
+ -- Name is p[himpl:H]:H.T, NOT himplH:H.T. That's OK but we just
+ -- have to look up the right name.
+ sig_type_occ_env = mkOccEnv
+ . map (\t -> (nameOccName (getName t), t))
+ $ nameEnvElts sig_type_env
+ dfun_names = map getName sig_insts
+ check_export name
+ -- Skip instances, we'll check them later
+ -- TODO: Actually this should never happen, because DFuns are
+ -- never exported...
+ | name `elem` dfun_names = return ()
+ -- See if we can find the type directly in the hsig ModDetails
+ -- TODO: need to special case wired in names
+ | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do
+ -- NB: We use tcLookupImported_maybe because we want to EXCLUDE
+ -- tcg_env (TODO: but maybe this isn't relevant anymore).
+ r <- tcLookupImported_maybe name
+ case r of
+ Failed err -> addErr err
+ Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing
+
+ -- The hsig did NOT define this function; that means it must
+ -- be a reexport. In this case, make sure the 'Name' of the
+ -- reexport matches the 'Name exported here.
+ | [GRE { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) =
+ when (name /= name') $ do
+ -- See Note [Error reporting bad reexport]
+ -- TODO: Actually this error swizzle doesn't work
+ let p (L _ ie) = name `elem` ieNames ie
+ loc = case tcg_rn_exports tcg_env of
+ Just es | Just e <- find p (map fst es)
+ -- TODO: maybe we can be a little more
+ -- precise here and use the Located
+ -- info for the *specific* name we matched.
+ -> getLoc e
+ _ -> nameSrcSpan name
+ addErrAt loc
+ (badReexportedBootThing False name name')
+ -- This should actually never happen, but whatever...
+ | otherwise =
+ addErrAt (nameSrcSpan name)
+ (missingBootThing False name "exported by")
+
+-- Note [Error reporting bad reexport]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- NB: You want to be a bit careful about what location you report on reexports.
+-- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the
+-- correct source location. However, if it was *reexported*, obviously the name
+-- is not going to have the right location. In this case, we need to grovel in
+-- tcg_rn_exports to figure out where the reexport came from.
+
+
+
+-- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't
+-- assume that the implementing file actually implemented the instances (they
+-- may be reexported from elsewhere). Where should we look for the instances?
+-- We do the same as we would otherwise: consult the EPS. This isn't perfect
+-- (we might conclude the module exports an instance when it doesn't, see
+-- #9422), but we will never refuse to compile something.
+check_inst :: ClsInst -> TcM ()
+check_inst sig_inst = do
+ -- TODO: This could be very well generalized to support instance
+ -- declarations in boot files.
+ tcg_env <- getGblEnv
+ -- NB: Have to tug on the interface, not necessarily
+ -- tugged... but it didn't work?
+ mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst))
+ -- Based off of 'simplifyDeriv'
+ let ty = idType (instanceDFunId sig_inst)
+ skol_info = InstSkol
+ -- Based off of tcSplitDFunTy
+ (tvs, theta, pred) =
+ case tcSplitForAllTys ty of { (tvs, rho) ->
+ case splitFunTys rho of { (theta, pred) ->
+ (tvs, theta, pred) }}
+ origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst
+ (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
+ (tclvl,cts) <- pushTcLevelM $ do
+ wanted <- newWanted origin
+ (Just TypeLevel)
+ (substTy skol_subst pred)
+ givens <- forM theta $ \given -> do
+ loc <- getCtLocM origin (Just TypeLevel)
+ let given_pred = substTy skol_subst given
+ new_ev <- newEvVar given_pred
+ return CtGiven { ctev_pred = given_pred
+ -- Doesn't matter, make something up
+ , ctev_evar = new_ev
+ , ctev_loc = loc
+ }
+ return $ wanted : givens
+ unsolved <- simplifyWantedsTcM cts
+
+ (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved
+ reportAllUnsolved (mkImplicWC implic)
+
+-- | Return this list of requirement interfaces that need to be merged
+-- to form @mod_name@, or @[]@ if this is not a requirement.
+requirementMerges :: PackageState -> ModuleName -> [IndefModule]
+requirementMerges pkgstate mod_name =
+ fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate))
+ where
+ -- update ComponentId cached details as they may have changed since the
+ -- time the ComponentId was created
+ fixupModule (IndefModule iud name) = IndefModule iud' name
+ where
+ iud' = iud { indefUnitIdComponentId = cid' }
+ cid = indefUnitIdComponentId iud
+ cid' = updateComponentId pkgstate cid
+
+-- | For a module @modname@ of type 'HscSource', determine the list
+-- of extra "imports" of other requirements which should be considered part of
+-- the import of the requirement, because it transitively depends on those
+-- requirements by imports of modules from other packages. The situation
+-- is something like this:
+--
+-- unit p where
+-- signature A
+-- signature B
+-- import A
+--
+-- unit q where
+-- dependency p[A=<A>,B=<B>]
+-- signature A
+-- signature B
+--
+-- Although q's B does not directly import A, we still have to make sure we
+-- process A first, because the merging process will cause B to indirectly
+-- import A. This function finds the TRANSITIVE closure of all such imports
+-- we need to make.
+findExtraSigImports' :: HscEnv
+ -> HscSource
+ -> ModuleName
+ -> IO (UniqDSet ModuleName)
+findExtraSigImports' hsc_env HsigFile modname =
+ fmap unionManyUniqDSets (forM reqs $ \(IndefModule iuid mod_name) ->
+ (initIfaceLoad hsc_env
+ . withException
+ $ moduleFreeHolesPrecise (text "findExtraSigImports")
+ (mkModule (IndefiniteUnitId iuid) mod_name)))
+ where
+ pkgstate = pkgState (hsc_dflags hsc_env)
+ reqs = requirementMerges pkgstate modname
+
+findExtraSigImports' _ _ _ = return emptyUniqDSet
+
+-- | 'findExtraSigImports', but in a convenient form for "GHC.Driver.Make" and
+-- "GHC.Tc.Module".
+findExtraSigImports :: HscEnv -> HscSource -> ModuleName
+ -> IO [(Maybe FastString, Located ModuleName)]
+findExtraSigImports hsc_env hsc_src modname = do
+ extra_requirements <- findExtraSigImports' hsc_env hsc_src modname
+ return [ (Nothing, noLoc mod_name)
+ | mod_name <- uniqDSetToList extra_requirements ]
+
+-- A version of 'implicitRequirements'' which is more friendly
+-- for "GHC.Driver.Make" and "GHC.Tc.Module".
+implicitRequirements :: HscEnv
+ -> [(Maybe FastString, Located ModuleName)]
+ -> IO [(Maybe FastString, Located ModuleName)]
+implicitRequirements hsc_env normal_imports
+ = do mns <- implicitRequirements' hsc_env normal_imports
+ return [ (Nothing, noLoc mn) | mn <- mns ]
+
+-- Given a list of 'import M' statements in a module, figure out
+-- any extra implicit requirement imports they may have. For
+-- example, if they 'import M' and M resolves to p[A=<B>], then
+-- they actually also import the local requirement B.
+implicitRequirements' :: HscEnv
+ -> [(Maybe FastString, Located ModuleName)]
+ -> IO [ModuleName]
+implicitRequirements' hsc_env normal_imports
+ = fmap concat $
+ forM normal_imports $ \(mb_pkg, L _ imp) -> do
+ found <- findImportedModule hsc_env imp mb_pkg
+ case found of
+ Found _ mod | thisPackage dflags /= moduleUnitId mod ->
+ return (uniqDSetToList (moduleFreeHoles mod))
+ _ -> return []
+ where dflags = hsc_dflags hsc_env
+
+-- | Given a 'UnitId', make sure it is well typed. This is because
+-- unit IDs come from Cabal, which does not know if things are well-typed or
+-- not; a component may have been filled with implementations for the holes
+-- that don't actually fulfill the requirements.
+--
+-- INVARIANT: the UnitId is NOT a InstalledUnitId
+checkUnitId :: UnitId -> TcM ()
+checkUnitId uid = do
+ case splitUnitIdInsts uid of
+ (_, Just indef) ->
+ let insts = indefUnitIdInsts indef in
+ forM_ insts $ \(mod_name, mod) ->
+ -- NB: direct hole instantiations are well-typed by construction
+ -- (because we FORCE things to be merged in), so don't check them
+ when (not (isHoleModule mod)) $ do
+ checkUnitId (moduleUnitId mod)
+ _ <- mod `checkImplements` IndefModule indef mod_name
+ return ()
+ _ -> return () -- if it's hashed, must be well-typed
+
+-- | Top-level driver for signature instantiation (run when compiling
+-- an @hsig@ file.)
+tcRnCheckUnitId ::
+ HscEnv -> UnitId ->
+ IO (Messages, Maybe ())
+tcRnCheckUnitId hsc_env uid =
+ withTiming dflags
+ (text "Check unit id" <+> ppr uid)
+ (const ()) $
+ initTc hsc_env
+ HsigFile -- bogus
+ False
+ mAIN -- bogus
+ (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus
+ $ checkUnitId uid
+ where
+ dflags = hsc_dflags hsc_env
+ loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid)
+
+-- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear...
+
+-- | Top-level driver for signature merging (run after typechecking
+-- an @hsig@ file).
+tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface
+ -> IO (Messages, Maybe TcGblEnv)
+tcRnMergeSignatures hsc_env hpm orig_tcg_env iface =
+ withTiming dflags
+ (text "Signature merging" <+> brackets (ppr this_mod))
+ (const ()) $
+ initTc hsc_env HsigFile False this_mod real_loc $
+ mergeSignatures hpm orig_tcg_env iface
+ where
+ dflags = hsc_dflags hsc_env
+ this_mod = mi_module iface
+ real_loc = tcg_top_loc orig_tcg_env
+
+thinModIface :: [AvailInfo] -> ModIface -> ModIface
+thinModIface avails iface =
+ iface {
+ mi_exports = avails,
+ -- mi_fixities = ...,
+ -- mi_warns = ...,
+ -- mi_anns = ...,
+ -- TODO: The use of nameOccName here is a bit dodgy, because
+ -- perhaps there might be two IfaceTopBndr that are the same
+ -- OccName but different Name. Requires better understanding
+ -- of invariants here.
+ mi_decls = exported_decls ++ non_exported_decls ++ dfun_decls
+ -- mi_insts = ...,
+ -- mi_fam_insts = ...,
+ }
+ where
+ decl_pred occs decl = nameOccName (ifName decl) `elemOccSet` occs
+ filter_decls occs = filter (decl_pred occs . snd) (mi_decls iface)
+
+ exported_occs = mkOccSet [ occName n
+ | a <- avails
+ , n <- availNames a ]
+ exported_decls = filter_decls exported_occs
+
+ non_exported_occs = mkOccSet [ occName n
+ | (_, d) <- exported_decls
+ , n <- ifaceDeclNeverExportedRefs d ]
+ non_exported_decls = filter_decls non_exported_occs
+
+ dfun_pred IfaceId{ ifIdDetails = IfDFunId } = True
+ dfun_pred _ = False
+ dfun_decls = filter (dfun_pred . snd) (mi_decls iface)
+
+-- | The list of 'Name's of *non-exported* 'IfaceDecl's which this
+-- 'IfaceDecl' may refer to. A non-exported 'IfaceDecl' should be kept
+-- after thinning if an *exported* 'IfaceDecl' (or 'mi_insts', perhaps)
+-- refers to it; we can't decide to keep it by looking at the exports
+-- of a module after thinning. Keep this synchronized with
+-- 'rnIfaceDecl'.
+ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name]
+ifaceDeclNeverExportedRefs d@IfaceFamily{} =
+ case ifFamFlav d of
+ IfaceClosedSynFamilyTyCon (Just (n, _))
+ -> [n]
+ _ -> []
+ifaceDeclNeverExportedRefs _ = []
+
+
+-- Note [Blank hsigs for all requirements]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- One invariant that a client of GHC must uphold is that there
+-- must be an hsig file for every requirement (according to
+-- @-this-unit-id@); this ensures that for every interface
+-- file (hi), there is a source file (hsig), which helps grease
+-- the wheels of recompilation avoidance which assumes that
+-- source files always exist.
+
+{-
+inheritedSigPvpWarning :: WarningTxt
+inheritedSigPvpWarning =
+ WarningTxt (noLoc NoSourceText) [noLoc (StringLiteral NoSourceText (fsLit msg))]
+ where
+ msg = "Inherited requirements from non-signature libraries (libraries " ++
+ "with modules) should not be used, as this mode of use is not " ++
+ "compatible with PVP-style version bounds. Instead, copy the " ++
+ "declaration to the local hsig file or move the signature to a " ++
+ "library of its own and add that library as a dependency."
+-}
+
+-- Note [Handling never-exported TyThings under Backpack]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- DEFINITION: A "never-exported TyThing" is a TyThing whose 'Name' will
+-- never be mentioned in the export list of a module (mi_avails).
+-- Unlike implicit TyThings (Note [Implicit TyThings]), non-exported
+-- TyThings DO have a standalone IfaceDecl declaration in their
+-- interface file.
+--
+-- Originally, Backpack was designed under the assumption that anything
+-- you could declare in a module could also be exported; thus, merging
+-- the export lists of two signatures is just merging the declarations
+-- of two signatures writ small. Of course, in GHC Haskell, there are a
+-- few important things which are not explicitly exported but still can
+-- be used: in particular, dictionary functions for instances, Typeable
+-- TyCon bindings, and coercion axioms for type families also count.
+--
+-- When handling these non-exported things, there two primary things
+-- we need to watch out for:
+--
+-- * Signature matching/merging is done by comparing each
+-- of the exported entities of a signature and a module. These exported
+-- entities may refer to non-exported TyThings which must be tested for
+-- consistency. For example, an instance (ClsInst) will refer to a
+-- non-exported DFunId. In this case, 'checkBootDeclM' directly compares the
+-- embedded 'DFunId' in 'is_dfun'.
+--
+-- For this to work at all, we must ensure that pointers in 'is_dfun' refer
+-- to DISTINCT 'DFunId's, even though the 'Name's (may) be the same.
+-- Unfortunately, this is the OPPOSITE of how we treat most other references
+-- to 'Name's, so this case needs to be handled specially.
+--
+-- The details are in the documentation for 'typecheckIfacesForMerging'.
+-- and the Note [Resolving never-exported Names] in GHC.IfaceToCore.
+--
+-- * When we rename modules and signatures, we use the export lists to
+-- decide how the declarations should be renamed. However, this
+-- means we don't get any guidance for how to rename non-exported
+-- entities. Fortunately, we only need to rename these entities
+-- *consistently*, so that 'typecheckIfacesForMerging' can wire them
+-- up as needed.
+--
+-- The details are in Note [rnIfaceNeverExported] in 'GHC.Iface.Rename'.
+--
+-- The root cause for all of these complications is the fact that these
+-- logically "implicit" entities are defined indirectly in an interface
+-- file. #13151 gives a proposal to make these *truly* implicit.
+
+merge_msg :: ModuleName -> [IndefModule] -> SDoc
+merge_msg mod_name [] =
+ text "while checking the local signature" <+> ppr mod_name <+>
+ text "for consistency"
+merge_msg mod_name reqs =
+ hang (text "while merging the signatures from" <> colon)
+ 2 (vcat [ bullet <+> ppr req | req <- reqs ] $$
+ bullet <+> text "...and the local signature for" <+> ppr mod_name)
+
+-- | Given a local 'ModIface', merge all inherited requirements
+-- from 'requirementMerges' into this signature, producing
+-- a final 'TcGblEnv' that matches the local signature and
+-- all required signatures.
+mergeSignatures :: HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv
+mergeSignatures
+ (HsParsedModule { hpm_module = L loc (HsModule { hsmodExports = mb_exports }),
+ hpm_src_files = src_files })
+ orig_tcg_env lcl_iface0 = setSrcSpan loc $ do
+ -- The lcl_iface0 is the ModIface for the local hsig
+ -- file, which is guaranteed to exist, see
+ -- Note [Blank hsigs for all requirements]
+ hsc_env <- getTopEnv
+ dflags <- getDynFlags
+
+ -- Copy over some things from the original TcGblEnv that
+ -- we want to preserve
+ updGblEnv (\env -> env {
+ -- Renamed imports/declarations are often used
+ -- by programs that use the GHC API, e.g., Haddock.
+ -- These won't get filled by the merging process (since
+ -- we don't actually rename the parsed module again) so
+ -- we need to take them directly from the previous
+ -- typechecking.
+ --
+ -- NB: the export declarations aren't in their final
+ -- form yet. We'll fill those in when we reprocess
+ -- the export declarations.
+ tcg_rn_imports = tcg_rn_imports orig_tcg_env,
+ tcg_rn_decls = tcg_rn_decls orig_tcg_env,
+ -- Annotations
+ tcg_ann_env = tcg_ann_env orig_tcg_env,
+ -- Documentation header
+ tcg_doc_hdr = tcg_doc_hdr orig_tcg_env
+ -- tcg_dus?
+ -- tcg_th_used = tcg_th_used orig_tcg_env,
+ -- tcg_th_splice_used = tcg_th_splice_used orig_tcg_env
+ }) $ do
+ tcg_env <- getGblEnv
+
+ let outer_mod = tcg_mod tcg_env
+ inner_mod = tcg_semantic_mod tcg_env
+ mod_name = moduleName (tcg_mod tcg_env)
+ pkgstate = pkgState dflags
+
+ -- STEP 1: Figure out all of the external signature interfaces
+ -- we are going to merge in.
+ let reqs = requirementMerges pkgstate mod_name
+
+ addErrCtxt (merge_msg mod_name reqs) $ do
+
+ -- STEP 2: Read in the RAW forms of all of these interfaces
+ ireq_ifaces0 <- forM reqs $ \(IndefModule iuid mod_name) ->
+ let m = mkModule (IndefiniteUnitId iuid) mod_name
+ im = fst (splitModuleInsts m)
+ in fmap fst
+ . withException
+ $ findAndReadIface (text "mergeSignatures") im m False
+
+ -- STEP 3: Get the unrenamed exports of all these interfaces,
+ -- thin it according to the export list, and do shaping on them.
+ let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as
+ -- This function gets run on every inherited interface, and
+ -- it's responsible for:
+ --
+ -- 1. Merging the exports of the interface into @nsubst@,
+ -- 2. Adding these exports to the "OK to import" set (@oks@)
+ -- if they came from a package with no exposed modules
+ -- (this means we won't report a PVP error in this case), and
+ -- 3. Thinning the interface according to an explicit export
+ -- list.
+ --
+ gen_subst (nsubst,oks,ifaces) (imod@(IndefModule iuid _), ireq_iface) = do
+ let insts = indefUnitIdInsts iuid
+ isFromSignaturePackage =
+ let inst_uid = fst (splitUnitIdInsts (IndefiniteUnitId iuid))
+ pkg = getInstalledPackageDetails pkgstate inst_uid
+ in null (exposedModules pkg)
+ -- 3(a). Rename the exports according to how the dependency
+ -- was instantiated. The resulting export list will be accurate
+ -- except for exports *from the signature itself* (which may
+ -- be subsequently updated by exports from other signatures in
+ -- the merge.
+ as1 <- tcRnModExports insts ireq_iface
+ -- 3(b). Thin the interface if it comes from a signature package.
+ (thinned_iface, as2) <- case mb_exports of
+ Just (L loc _)
+ -- Check if the package containing this signature is
+ -- a signature package (i.e., does not expose any
+ -- modules.) If so, we can thin it.
+ | isFromSignaturePackage
+ -> setSrcSpan loc $ do
+ -- Suppress missing errors; they might be used to refer
+ -- to entities from other signatures we are merging in.
+ -- If an identifier truly doesn't exist in any of the
+ -- signatures that are merged in, we will discover this
+ -- when we run exports_from_avail on the final merged
+ -- export list.
+ (mb_r, msgs) <- tryTc $ do
+ -- Suppose that we have written in a signature:
+ -- signature A ( module A ) where {- empty -}
+ -- If I am also inheriting a signature from a
+ -- signature package, does 'module A' scope over
+ -- all of its exports?
+ --
+ -- There are two possible interpretations:
+ --
+ -- 1. For non self-reexports, a module reexport
+ -- is interpreted only in terms of the local
+ -- signature module, and not any of the inherited
+ -- ones. The reason for this is because after
+ -- typechecking, module exports are completely
+ -- erased from the interface of a file, so we
+ -- have no way of "interpreting" a module reexport.
+ -- Thus, it's only useful for the local signature
+ -- module (where we have a useful GlobalRdrEnv.)
+ --
+ -- 2. On the other hand, a common idiom when
+ -- you want to "export everything, plus a reexport"
+ -- in modules is to say module A ( module A, reex ).
+ -- This applies to signature modules too; and in
+ -- particular, you probably still want the entities
+ -- from the inherited signatures to be preserved
+ -- too.
+ --
+ -- We think it's worth making a special case for
+ -- self reexports to make use case (2) work. To
+ -- do this, we take the exports of the inherited
+ -- signature @as1@, and bundle them into a
+ -- GlobalRdrEnv where we treat them as having come
+ -- from the import @import A@. Thus, we will
+ -- pick them up if they are referenced explicitly
+ -- (@foo@) or even if we do a module reexport
+ -- (@module A@).
+ let ispec = ImpSpec ImpDeclSpec{
+ -- NB: This needs to be mod name
+ -- of the local signature, not
+ -- the (original) module name of
+ -- the inherited signature,
+ -- because we need module
+ -- LocalSig (from the local
+ -- export list) to match it!
+ is_mod = mod_name,
+ is_as = mod_name,
+ is_qual = False,
+ is_dloc = loc
+ } ImpAll
+ rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1)
+ setGblEnv tcg_env {
+ tcg_rdr_env = rdr_env
+ } $ exports_from_avail mb_exports rdr_env
+ -- NB: tcg_imports is also empty!
+ emptyImportAvails
+ (tcg_semantic_mod tcg_env)
+ case mb_r of
+ Just (_, as2) -> return (thinModIface as2 ireq_iface, as2)
+ Nothing -> addMessages msgs >> failM
+ -- We can't think signatures from non signature packages
+ _ -> return (ireq_iface, as1)
+ -- 3(c). Only identifiers from signature packages are "ok" to
+ -- import (that is, they are safe from a PVP perspective.)
+ -- (NB: This code is actually dead right now.)
+ let oks' | isFromSignaturePackage
+ = extendOccSetList oks (exportOccs as2)
+ | otherwise
+ = oks
+ -- 3(d). Extend the name substitution (performing shaping)
+ mb_r <- extend_ns nsubst as2
+ case mb_r of
+ Left err -> failWithTc err
+ Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces)
+ nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0)
+ ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0))
+ -- Process each interface, getting the thinned interfaces as well as
+ -- the final, full set of exports @nsubst@ and the exports which are
+ -- "ok to use" (we won't attach 'inheritedSigPvpWarning' to them.)
+ (nsubst, ok_to_use, rev_thinned_ifaces)
+ <- foldM gen_subst (nsubst0, ok_to_use0, []) (zip reqs ireq_ifaces0)
+ let thinned_ifaces = reverse rev_thinned_ifaces
+ exports = nameShapeExports nsubst
+ rdr_env = mkGlobalRdrEnv (gresFromAvails Nothing exports)
+ _warn_occs = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports)
+ warns = NoWarnings
+ {-
+ -- TODO: Warnings are transitive, but this is not what we want here:
+ -- if a module reexports an entity from a signature, that should be OK.
+ -- Not supported in current warning framework
+ warns | null warn_occs = NoWarnings
+ | otherwise = WarnSome $ map (\o -> (o, inheritedSigPvpWarning)) warn_occs
+ -}
+ setGblEnv tcg_env {
+ -- The top-level GlobalRdrEnv is quite interesting. It consists
+ -- of two components:
+ -- 1. First, we reuse the GlobalRdrEnv of the local signature.
+ -- This is very useful, because it means that if we have
+ -- to print a message involving some entity that the local
+ -- signature imported, we'll qualify it accordingly.
+ -- 2. Second, we need to add all of the declarations we are
+ -- going to merge in (as they need to be in scope for the
+ -- final test of the export list.)
+ tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env orig_tcg_env,
+ -- Inherit imports from the local signature, so that module
+ -- reexports are picked up correctly
+ tcg_imports = tcg_imports orig_tcg_env,
+ tcg_exports = exports,
+ tcg_dus = usesOnly (availsToNameSetWithSelectors exports),
+ tcg_warns = warns
+ } $ do
+ tcg_env <- getGblEnv
+
+ -- Make sure we didn't refer to anything that doesn't actually exist
+ -- pprTrace "mergeSignatures: exports_from_avail" (ppr exports) $ return ()
+ (mb_lies, _) <- exports_from_avail mb_exports rdr_env
+ (tcg_imports tcg_env) (tcg_semantic_mod tcg_env)
+
+ {- -- NB: This is commented out, because warns above is disabled.
+ -- If you tried to explicitly export an identifier that has a warning
+ -- attached to it, that's probably a mistake. Warn about it.
+ case mb_lies of
+ Nothing -> return ()
+ Just lies ->
+ forM_ (concatMap (\(L loc x) -> map (L loc) (ieNames x)) lies) $ \(L loc n) ->
+ setSrcSpan loc $
+ unless (nameOccName n `elemOccSet` ok_to_use) $
+ addWarn NoReason $ vcat [
+ text "Exported identifier" <+> quotes (ppr n) <+> text "will cause warnings if used.",
+ parens (text "To suppress this warning, remove" <+> quotes (ppr n) <+> text "from the export list of this signature.")
+ ]
+ -}
+
+ failIfErrsM
+
+ -- Save the exports
+ setGblEnv tcg_env { tcg_rn_exports = mb_lies } $ do
+ tcg_env <- getGblEnv
+
+ -- STEP 4: Rename the interfaces
+ ext_ifaces <- forM thinned_ifaces $ \((IndefModule iuid _), ireq_iface) ->
+ tcRnModIface (indefUnitIdInsts iuid) (Just nsubst) ireq_iface
+ lcl_iface <- tcRnModIface (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0
+ let ifaces = lcl_iface : ext_ifaces
+
+ -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env
+ let fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)
+ | (occ, f) <- concatMap mi_fixities ifaces
+ , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ]
+
+ -- STEP 5: Typecheck the interfaces
+ let type_env_var = tcg_type_env_var tcg_env
+
+ -- typecheckIfacesForMerging does two things:
+ -- 1. It merges the all of the ifaces together, and typechecks the
+ -- result to type_env.
+ -- 2. It typechecks each iface individually, but with their 'Name's
+ -- resolving to the merged type_env from (1).
+ -- See typecheckIfacesForMerging for more details.
+ (type_env, detailss) <- initIfaceTcRn $
+ typecheckIfacesForMerging inner_mod ifaces type_env_var
+ let infos = zip ifaces detailss
+
+ -- Test for cycles
+ checkSynCycles (thisPackage dflags) (typeEnvTyCons type_env) []
+
+ -- NB on type_env: it contains NO dfuns. DFuns are recorded inside
+ -- detailss, and given a Name that doesn't correspond to anything real. See
+ -- also Note [Signature merging DFuns]
+
+ -- Add the merged type_env to TcGblEnv, so that it gets serialized
+ -- out when we finally write out the interface.
+ --
+ -- NB: Why do we set tcg_tcs/tcg_patsyns/tcg_type_env directly,
+ -- rather than use tcExtendGlobalEnv (the normal method to add newly
+ -- defined types to TcGblEnv?) tcExtendGlobalEnv adds these
+ -- TyThings to 'tcg_type_env_var', which is consulted when
+ -- we read in interfaces to tie the knot. But *these TyThings themselves
+ -- come from interface*, so that would result in deadlock. Don't
+ -- update it!
+ setGblEnv tcg_env {
+ tcg_tcs = typeEnvTyCons type_env,
+ tcg_patsyns = typeEnvPatSyns type_env,
+ tcg_type_env = type_env,
+ tcg_fix_env = fix_env
+ } $ do
+ tcg_env <- getGblEnv
+
+ -- STEP 6: Check for compatibility/merge things
+ tcg_env <- (\x -> foldM x tcg_env infos)
+ $ \tcg_env (iface, details) -> do
+
+ let check_export name
+ | Just sig_thing <- lookupTypeEnv (md_types details) name
+ = case lookupTypeEnv type_env (getName sig_thing) of
+ Just thing -> checkHsigDeclM iface sig_thing thing
+ Nothing -> panic "mergeSignatures: check_export"
+ -- Oops! We're looking for this export but it's
+ -- not actually in the type environment of the signature's
+ -- ModDetails.
+ --
+ -- NB: This case happens because the we're iterating
+ -- over the union of all exports, so some interfaces
+ -- won't have everything. Note that md_exports is nonsense
+ -- (it's the same as exports); maybe we should fix this
+ -- eventually.
+ | otherwise
+ = return ()
+ mapM_ check_export (map availName exports)
+
+ -- Note [Signature merging instances]
+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ -- Merge instances into the global environment. The algorithm here is
+ -- dumb and simple: if an instance has exactly the same DFun type
+ -- (tested by 'memberInstEnv') as an existing instance, we drop it;
+ -- otherwise, we add it even, even if this would cause overlap.
+ --
+ -- Why don't we deduplicate instances with identical heads? There's no
+ -- good choice if they have premises:
+ --
+ -- instance K1 a => K (T a)
+ -- instance K2 a => K (T a)
+ --
+ -- Why not eagerly error in this case? The overlapping head does not
+ -- necessarily mean that the instances are unimplementable: in fact,
+ -- they may be implemented without overlap (if, for example, the
+ -- implementing module has 'instance K (T a)'; both are implemented in
+ -- this case.) The implements test just checks that the wanteds are
+ -- derivable assuming the givens.
+ --
+ -- Still, overlapping instances with hypotheses like above are going
+ -- to be a bad deal, because instance resolution when we're typechecking
+ -- against the merged signature is going to have a bad time when
+ -- there are overlapping heads like this: we never backtrack, so it
+ -- may be difficult to see that a wanted is derivable. For now,
+ -- we hope that we get lucky / the overlapping instances never
+ -- get used, but it is not a very good situation to be in.
+ --
+ let merge_inst (insts, inst_env) inst
+ | memberInstEnv inst_env inst -- test DFun Type equality
+ = (insts, inst_env)
+ | otherwise
+ -- NB: is_dfun_name inst is still nonsense here,
+ -- see Note [Signature merging DFuns]
+ = (inst:insts, extendInstEnv inst_env inst)
+ (insts, inst_env) = foldl' merge_inst
+ (tcg_insts tcg_env, tcg_inst_env tcg_env)
+ (md_insts details)
+ -- This is a HACK to prevent calculateAvails from including imp_mod
+ -- in the listing. We don't want it because a module is NOT
+ -- supposed to include itself in its dep_orphs/dep_finsts. See #13214
+ iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } }
+ avails = plusImportAvails (tcg_imports tcg_env) $
+ calculateAvails dflags iface' False False ImportedBySystem
+ return tcg_env {
+ tcg_inst_env = inst_env,
+ tcg_insts = insts,
+ tcg_imports = avails,
+ tcg_merged =
+ if outer_mod == mi_module iface
+ -- Don't add ourselves!
+ then tcg_merged tcg_env
+ else (mi_module iface, mi_mod_hash (mi_final_exts iface)) : tcg_merged tcg_env
+ }
+
+ -- Note [Signature merging DFuns]
+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ -- Once we know all of instances which will be defined by this merged
+ -- signature, we go through each of the DFuns and rename them with a fresh,
+ -- new, unique DFun Name, and add these DFuns to tcg_type_env (thus fixing
+ -- up the "bogus" names that were setup in 'typecheckIfacesForMerging'.
+ --
+ -- We can't do this fixup earlier, because we need a way to identify each
+ -- source DFun (from each of the signatures we are merging in) so that
+ -- when we have a ClsInst, we can pull up the correct DFun to check if
+ -- the types match.
+ --
+ -- See also Note [rnIfaceNeverExported] in GHC.Iface.Rename
+ dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do
+ n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst))
+ let dfun = setVarName (is_dfun inst) n
+ return (dfun, inst { is_dfun_name = n, is_dfun = dfun })
+ tcg_env <- return tcg_env {
+ tcg_insts = map snd dfun_insts,
+ tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts)
+ }
+
+ addDependentFiles src_files
+
+ return tcg_env
+
+-- | Top-level driver for signature instantiation (run when compiling
+-- an @hsig@ file.)
+tcRnInstantiateSignature ::
+ HscEnv -> Module -> RealSrcSpan ->
+ IO (Messages, Maybe TcGblEnv)
+tcRnInstantiateSignature hsc_env this_mod real_loc =
+ withTiming dflags
+ (text "Signature instantiation"<+>brackets (ppr this_mod))
+ (const ()) $
+ initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature
+ where
+ dflags = hsc_dflags hsc_env
+
+exportOccs :: [AvailInfo] -> [OccName]
+exportOccs = concatMap (map occName . availNames)
+
+impl_msg :: Module -> IndefModule -> SDoc
+impl_msg impl_mod (IndefModule req_uid req_mod_name) =
+ text "while checking that" <+> ppr impl_mod <+>
+ text "implements signature" <+> ppr req_mod_name <+>
+ text "in" <+> ppr req_uid
+
+-- | Check if module implements a signature. (The signature is
+-- always un-hashed, which is why its components are specified
+-- explicitly.)
+checkImplements :: Module -> IndefModule -> TcRn TcGblEnv
+checkImplements impl_mod req_mod@(IndefModule uid mod_name) =
+ addErrCtxt (impl_msg impl_mod req_mod) $ do
+ let insts = indefUnitIdInsts uid
+
+ -- STEP 1: Load the implementing interface, and make a RdrEnv
+ -- for its exports. Also, add its 'ImportAvails' to 'tcg_imports',
+ -- so that we treat all orphan instances it provides as visible
+ -- when we verify that all instances are checked (see #12945), and so that
+ -- when we eventually write out the interface we record appropriate
+ -- dependency information.
+ impl_iface <- initIfaceTcRn $
+ loadSysInterface (text "checkImplements 1") impl_mod
+ let impl_gr = mkGlobalRdrEnv
+ (gresFromAvails Nothing (mi_exports impl_iface))
+ nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface)
+
+ -- Load all the orphans, so the subsequent 'checkHsigIface' sees
+ -- all the instances it needs to
+ loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)")
+ (dep_orphs (mi_deps impl_iface))
+
+ dflags <- getDynFlags
+ let avails = calculateAvails dflags
+ impl_iface False{- safe -} False{- boot -} ImportedBySystem
+ fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)
+ | (occ, f) <- mi_fixities impl_iface
+ , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ]
+ updGblEnv (\tcg_env -> tcg_env {
+ -- Setting tcg_rdr_env to treat all exported entities from
+ -- the implementing module as in scope improves error messages,
+ -- as it reduces the amount of qualification we need. Unfortunately,
+ -- we still end up qualifying references to external modules
+ -- (see bkpfail07 for an example); we'd need to record more
+ -- information in ModIface to solve this.
+ tcg_rdr_env = tcg_rdr_env tcg_env `plusGlobalRdrEnv` impl_gr,
+ tcg_imports = tcg_imports tcg_env `plusImportAvails` avails,
+ -- This is here so that when we call 'lookupFixityRn' for something
+ -- directly implemented by the module, we grab the right thing
+ tcg_fix_env = fix_env
+ }) $ do
+
+ -- STEP 2: Load the *unrenamed, uninstantiated* interface for
+ -- the ORIGINAL signature. We are going to eventually rename it,
+ -- but we must proceed slowly, because it is NOT known if the
+ -- instantiation is correct.
+ let sig_mod = mkModule (IndefiniteUnitId uid) mod_name
+ isig_mod = fst (splitModuleInsts sig_mod)
+ mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod sig_mod False
+ isig_iface <- case mb_isig_iface of
+ Succeeded (iface, _) -> return iface
+ Failed err -> failWithTc $
+ hang (text "Could not find hi interface for signature" <+>
+ quotes (ppr isig_mod) <> colon) 4 err
+
+ -- STEP 3: Check that the implementing interface exports everything
+ -- we need. (Notice we IGNORE the Modules in the AvailInfos.)
+ forM_ (exportOccs (mi_exports isig_iface)) $ \occ ->
+ case lookupGlobalRdrEnv impl_gr occ of
+ [] -> addErr $ quotes (ppr occ)
+ <+> text "is exported by the hsig file, but not"
+ <+> text "exported by the implementing module"
+ <+> quotes (ppr impl_mod)
+ _ -> return ()
+ failIfErrsM
+
+ -- STEP 4: Now that the export is complete, rename the interface...
+ sig_iface <- tcRnModIface insts (Just nsubst) isig_iface
+
+ -- STEP 5: ...and typecheck it. (Note that in both cases, the nsubst
+ -- lets us determine how top-level identifiers should be handled.)
+ sig_details <- initIfaceTcRn $ typecheckIfaceForInstantiate nsubst sig_iface
+
+ -- STEP 6: Check that it's sufficient
+ tcg_env <- getGblEnv
+ checkHsigIface tcg_env impl_gr sig_iface sig_details
+
+ -- STEP 7: Return the updated 'TcGblEnv' with the signature exports,
+ -- so we write them out.
+ return tcg_env {
+ tcg_exports = mi_exports sig_iface
+ }
+
+-- | Given 'tcg_mod', instantiate a 'ModIface' from the indefinite
+-- library to use the actual implementations of the relevant entities,
+-- checking that the implementation matches the signature.
+instantiateSignature :: TcRn TcGblEnv
+instantiateSignature = do
+ tcg_env <- getGblEnv
+ dflags <- getDynFlags
+ let outer_mod = tcg_mod tcg_env
+ inner_mod = tcg_semantic_mod tcg_env
+ -- TODO: setup the local RdrEnv so the error messages look a little better.
+ -- But this information isn't stored anywhere. Should we RETYPECHECK
+ -- the local one just to get the information? Hmm...
+ MASSERT( moduleUnitId outer_mod == thisPackage dflags )
+ inner_mod `checkImplements`
+ IndefModule
+ (newIndefUnitId (thisComponentId dflags)
+ (thisUnitIdInsts dflags))
+ (moduleName outer_mod)
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
new file mode 100644
index 0000000000..0154ed157e
--- /dev/null
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -0,0 +1,1110 @@
+-- (c) The University of Glasgow 2006
+{-# LANGUAGE CPP, FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an
+ -- orphan
+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
+ -- in module GHC.Hs.Extension
+{-# LANGUAGE TypeFamilies #-}
+
+module GHC.Tc.Utils.Env(
+ TyThing(..), TcTyThing(..), TcId,
+
+ -- Instance environment, and InstInfo type
+ InstInfo(..), iDFunId, pprInstInfoDetails,
+ simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
+ InstBindings(..),
+
+ -- Global environment
+ tcExtendGlobalEnv, tcExtendTyConEnv,
+ tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
+ tcExtendGlobalValEnv,
+ tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly,
+ tcLookupTyCon, tcLookupClass,
+ tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
+ tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
+ tcLookupLocatedClass, tcLookupAxiom,
+ lookupGlobal, ioLookupDataCon,
+ addTypecheckedBinds,
+
+ -- Local environment
+ tcExtendKindEnv, tcExtendKindEnvList,
+ tcExtendTyVarEnv, tcExtendNameTyVarEnv,
+ tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds,
+ tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
+ tcExtendBinderStack, tcExtendLocalTypeEnv,
+ isTypeClosedLetBndr,
+
+ tcLookup, tcLookupLocated, tcLookupLocalIds,
+ tcLookupId, tcLookupIdMaybe, tcLookupTyVar,
+ tcLookupTcTyCon,
+ tcLookupLcl_maybe,
+ getInLocalScope,
+ wrongThingErr, pprBinders,
+
+ tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders,
+ getTypeSigNames,
+ tcExtendRecEnv, -- For knot-tying
+
+ -- Tidying
+ tcInitTidyEnv, tcInitOpenTidyEnv,
+
+ -- Instances
+ tcLookupInstance, tcGetInstEnvs,
+
+ -- Rules
+ tcExtendRules,
+
+ -- Defaults
+ tcGetDefaultTys,
+
+ -- Template Haskell stuff
+ checkWellStaged, tcMetaTy, thLevel,
+ topIdLvl, isBrackStage,
+
+ -- New Ids
+ newDFunName, newFamInstTyConName,
+ newFamInstAxiomName,
+ mkStableIdFromString, mkStableIdFromName,
+ mkWrapperName
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHC.Hs
+import GHC.Iface.Env
+import GHC.Tc.Utils.Monad
+import GHC.Tc.Utils.TcMType
+import GHC.Tc.Utils.TcType
+import GHC.Iface.Load
+import PrelNames
+import TysWiredIn
+import GHC.Types.Id
+import GHC.Types.Var
+import GHC.Types.Name.Reader
+import GHC.Core.InstEnv
+import GHC.Core.DataCon ( DataCon )
+import GHC.Core.PatSyn ( PatSyn )
+import GHC.Core.ConLike
+import GHC.Core.TyCon
+import GHC.Core.Type
+import GHC.Core.Coercion.Axiom
+import GHC.Core.Class
+import GHC.Types.Name
+import GHC.Types.Name.Set
+import GHC.Types.Name.Env
+import GHC.Types.Var.Env
+import GHC.Driver.Types
+import GHC.Driver.Session
+import GHC.Types.SrcLoc
+import GHC.Types.Basic hiding( SuccessFlag(..) )
+import GHC.Types.Module
+import Outputable
+import Encoding
+import FastString
+import Bag
+import ListSetOps
+import ErrUtils
+import Maybes( MaybeErr(..), orElse )
+import qualified GHC.LanguageExtensions as LangExt
+import Util ( HasDebugCallStack )
+
+import Data.IORef
+import Data.List (intercalate)
+import Control.Monad
+
+{- *********************************************************************
+* *
+ An IO interface to looking up globals
+* *
+********************************************************************* -}
+
+lookupGlobal :: HscEnv -> Name -> IO TyThing
+-- A variant of lookupGlobal_maybe for the clients which are not
+-- interested in recovering from lookup failure and accept panic.
+lookupGlobal hsc_env name
+ = do {
+ mb_thing <- lookupGlobal_maybe hsc_env name
+ ; case mb_thing of
+ Succeeded thing -> return thing
+ Failed msg -> pprPanic "lookupGlobal" msg
+ }
+
+lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
+-- This may look up an Id that one one has previously looked up.
+-- If so, we are going to read its interface file, and add its bindings
+-- to the ExternalPackageTable.
+lookupGlobal_maybe hsc_env name
+ = do { -- Try local envt
+ let mod = icInteractiveModule (hsc_IC hsc_env)
+ dflags = hsc_dflags hsc_env
+ tcg_semantic_mod = canonicalizeModuleIfHome dflags mod
+
+ ; if nameIsLocalOrFrom tcg_semantic_mod name
+ then (return
+ (Failed (text "Can't find local name: " <+> ppr name)))
+ -- Internal names can happen in GHCi
+ else
+ -- Try home package table and external package table
+ lookupImported_maybe hsc_env name
+ }
+
+lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
+-- Returns (Failed err) if we can't find the interface file for the thing
+lookupImported_maybe hsc_env name
+ = do { mb_thing <- lookupTypeHscEnv hsc_env name
+ ; case mb_thing of
+ Just thing -> return (Succeeded thing)
+ Nothing -> importDecl_maybe hsc_env name
+ }
+
+importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
+importDecl_maybe hsc_env name
+ | Just thing <- wiredInNameTyThing_maybe name
+ = do { when (needWiredInHomeIface thing)
+ (initIfaceLoad hsc_env (loadWiredInHomeIface name))
+ -- See Note [Loading instances for wired-in things]
+ ; return (Succeeded thing) }
+ | otherwise
+ = initIfaceLoad hsc_env (importDecl name)
+
+ioLookupDataCon :: HscEnv -> Name -> IO DataCon
+ioLookupDataCon hsc_env name = do
+ mb_thing <- ioLookupDataCon_maybe hsc_env name
+ case mb_thing of
+ Succeeded thing -> return thing
+ Failed msg -> pprPanic "lookupDataConIO" msg
+
+ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc DataCon)
+ioLookupDataCon_maybe hsc_env name = do
+ thing <- lookupGlobal hsc_env name
+ return $ case thing of
+ AConLike (RealDataCon con) -> Succeeded con
+ _ -> Failed $
+ pprTcTyThingCategory (AGlobal thing) <+> quotes (ppr name) <+>
+ text "used as a data constructor"
+
+addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
+addTypecheckedBinds tcg_env binds
+ | isHsBootOrSig (tcg_src tcg_env) = tcg_env
+ -- Do not add the code for record-selector bindings
+ -- when compiling hs-boot files
+ | otherwise = tcg_env { tcg_binds = foldr unionBags
+ (tcg_binds tcg_env)
+ binds }
+
+{-
+************************************************************************
+* *
+* tcLookupGlobal *
+* *
+************************************************************************
+
+Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
+unless you know that the SrcSpan in the monad is already set to the
+span of the Name.
+-}
+
+
+tcLookupLocatedGlobal :: Located Name -> TcM TyThing
+-- c.f. GHC.IfaceToCore.tcIfaceGlobal
+tcLookupLocatedGlobal name
+ = addLocM tcLookupGlobal name
+
+tcLookupGlobal :: Name -> TcM TyThing
+-- The Name is almost always an ExternalName, but not always
+-- In GHCi, we may make command-line bindings (ghci> let x = True)
+-- that bind a GlobalId, but with an InternalName
+tcLookupGlobal name
+ = do { -- Try local envt
+ env <- getGblEnv
+ ; case lookupNameEnv (tcg_type_env env) name of {
+ Just thing -> return thing ;
+ Nothing ->
+
+ -- Should it have been in the local envt?
+ -- (NB: use semantic mod here, since names never use
+ -- identity module, see Note [Identity versus semantic module].)
+ if nameIsLocalOrFrom (tcg_semantic_mod env) name
+ then notFound name -- Internal names can happen in GHCi
+ else
+
+ -- Try home package table and external package table
+ do { mb_thing <- tcLookupImported_maybe name
+ ; case mb_thing of
+ Succeeded thing -> return thing
+ Failed msg -> failWithTc msg
+ }}}
+
+-- Look up only in this module's global env't. Don't look in imports, etc.
+-- Panic if it's not there.
+tcLookupGlobalOnly :: Name -> TcM TyThing
+tcLookupGlobalOnly name
+ = do { env <- getGblEnv
+ ; return $ case lookupNameEnv (tcg_type_env env) name of
+ Just thing -> thing
+ Nothing -> pprPanic "tcLookupGlobalOnly" (ppr name) }
+
+tcLookupDataCon :: Name -> TcM DataCon
+tcLookupDataCon name = do
+ thing <- tcLookupGlobal name
+ case thing of
+ AConLike (RealDataCon con) -> return con
+ _ -> wrongThingErr "data constructor" (AGlobal thing) name
+
+tcLookupPatSyn :: Name -> TcM PatSyn
+tcLookupPatSyn name = do
+ thing <- tcLookupGlobal name
+ case thing of
+ AConLike (PatSynCon ps) -> return ps
+ _ -> wrongThingErr "pattern synonym" (AGlobal thing) name
+
+tcLookupConLike :: Name -> TcM ConLike
+tcLookupConLike name = do
+ thing <- tcLookupGlobal name
+ case thing of
+ AConLike cl -> return cl
+ _ -> wrongThingErr "constructor-like thing" (AGlobal thing) name
+
+tcLookupClass :: Name -> TcM Class
+tcLookupClass name = do
+ thing <- tcLookupGlobal name
+ case thing of
+ ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls
+ _ -> wrongThingErr "class" (AGlobal thing) name
+
+tcLookupTyCon :: Name -> TcM TyCon
+tcLookupTyCon name = do
+ thing <- tcLookupGlobal name
+ case thing of
+ ATyCon tc -> return tc
+ _ -> wrongThingErr "type constructor" (AGlobal thing) name
+
+tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
+tcLookupAxiom name = do
+ thing <- tcLookupGlobal name
+ case thing of
+ ACoAxiom ax -> return ax
+ _ -> wrongThingErr "axiom" (AGlobal thing) name
+
+tcLookupLocatedGlobalId :: Located Name -> TcM Id
+tcLookupLocatedGlobalId = addLocM tcLookupId
+
+tcLookupLocatedClass :: Located Name -> TcM Class
+tcLookupLocatedClass = addLocM tcLookupClass
+
+tcLookupLocatedTyCon :: Located Name -> TcM TyCon
+tcLookupLocatedTyCon = addLocM tcLookupTyCon
+
+-- Find the instance that exactly matches a type class application. The class arguments must be precisely
+-- the same as in the instance declaration (modulo renaming & casts).
+--
+tcLookupInstance :: Class -> [Type] -> TcM ClsInst
+tcLookupInstance cls tys
+ = do { instEnv <- tcGetInstEnvs
+ ; case lookupUniqueInstEnv instEnv cls tys of
+ Left err -> failWithTc $ text "Couldn't match instance:" <+> err
+ Right (inst, tys)
+ | uniqueTyVars tys -> return inst
+ | otherwise -> failWithTc errNotExact
+ }
+ where
+ errNotExact = text "Not an exact match (i.e., some variables get instantiated)"
+
+ uniqueTyVars tys = all isTyVarTy tys
+ && hasNoDups (map (getTyVar "tcLookupInstance") tys)
+
+tcGetInstEnvs :: TcM InstEnvs
+-- Gets both the external-package inst-env
+-- and the home-pkg inst env (includes module being compiled)
+tcGetInstEnvs = do { eps <- getEps
+ ; env <- getGblEnv
+ ; return (InstEnvs { ie_global = eps_inst_env eps
+ , ie_local = tcg_inst_env env
+ , ie_visible = tcVisibleOrphanMods env }) }
+
+instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
+ lookupThing = tcLookupGlobal
+
+{-
+************************************************************************
+* *
+ Extending the global environment
+* *
+************************************************************************
+-}
+
+setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
+-- Use this to update the global type env
+-- It updates both * the normal tcg_type_env field
+-- * the tcg_type_env_var field seen by interface files
+setGlobalTypeEnv tcg_env new_type_env
+ = do { -- Sync the type-envt variable seen by interface files
+ writeMutVar (tcg_type_env_var tcg_env) new_type_env
+ ; return (tcg_env { tcg_type_env = new_type_env }) }
+
+
+tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r
+ -- Just extend the global environment with some TyThings
+ -- Do not extend tcg_tcs, tcg_patsyns etc
+tcExtendGlobalEnvImplicit things thing_inside
+ = do { tcg_env <- getGblEnv
+ ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things
+ ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
+ ; setGblEnv tcg_env' thing_inside }
+
+tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
+ -- Given a mixture of Ids, TyCons, Classes, all defined in the
+ -- module being compiled, extend the global environment
+tcExtendGlobalEnv things thing_inside
+ = do { env <- getGblEnv
+ ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env,
+ tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env }
+ ; setGblEnv env' $
+ tcExtendGlobalEnvImplicit things thing_inside
+ }
+
+tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r
+ -- Given a mixture of Ids, TyCons, Classes, all defined in the
+ -- module being compiled, extend the global environment
+tcExtendTyConEnv tycons thing_inside
+ = do { env <- getGblEnv
+ ; let env' = env { tcg_tcs = tycons ++ tcg_tcs env }
+ ; setGblEnv env' $
+ tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside
+ }
+
+tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
+ -- Same deal as tcExtendGlobalEnv, but for Ids
+tcExtendGlobalValEnv ids thing_inside
+ = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside
+
+tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
+-- Extend the global environments for the type/class knot tying game
+-- Just like tcExtendGlobalEnv, except the argument is a list of pairs
+tcExtendRecEnv gbl_stuff thing_inside
+ = do { tcg_env <- getGblEnv
+ ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff
+ tcg_env' = tcg_env { tcg_type_env = ge' }
+ -- No need for setGlobalTypeEnv (which side-effects the
+ -- tcg_type_env_var); tcExtendRecEnv is used just
+ -- when kind-check a group of type/class decls. It would
+ -- in any case be wrong for an interface-file decl to end up
+ -- with a TcTyCon in it!
+ ; setGblEnv tcg_env' thing_inside }
+
+{-
+************************************************************************
+* *
+\subsection{The local environment}
+* *
+************************************************************************
+-}
+
+tcLookupLocated :: Located Name -> TcM TcTyThing
+tcLookupLocated = addLocM tcLookup
+
+tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
+tcLookupLcl_maybe name
+ = do { local_env <- getLclTypeEnv
+ ; return (lookupNameEnv local_env name) }
+
+tcLookup :: Name -> TcM TcTyThing
+tcLookup name = do
+ local_env <- getLclTypeEnv
+ case lookupNameEnv local_env name of
+ Just thing -> return thing
+ Nothing -> AGlobal <$> tcLookupGlobal name
+
+tcLookupTyVar :: Name -> TcM TcTyVar
+tcLookupTyVar name
+ = do { thing <- tcLookup name
+ ; case thing of
+ ATyVar _ tv -> return tv
+ _ -> pprPanic "tcLookupTyVar" (ppr name) }
+
+tcLookupId :: Name -> TcM Id
+-- Used when we aren't interested in the binding level, nor refinement.
+-- The "no refinement" part means that we return the un-refined Id regardless
+--
+-- The Id is never a DataCon. (Why does that matter? see GHC.Tc.Gen.Expr.tcId)
+tcLookupId name = do
+ thing <- tcLookupIdMaybe name
+ case thing of
+ Just id -> return id
+ _ -> pprPanic "tcLookupId" (ppr name)
+
+tcLookupIdMaybe :: Name -> TcM (Maybe Id)
+tcLookupIdMaybe name
+ = do { thing <- tcLookup name
+ ; case thing of
+ ATcId { tct_id = id} -> return $ Just id
+ AGlobal (AnId id) -> return $ Just id
+ _ -> return Nothing }
+
+tcLookupLocalIds :: [Name] -> TcM [TcId]
+-- We expect the variables to all be bound, and all at
+-- the same level as the lookup. Only used in one place...
+tcLookupLocalIds ns
+ = do { env <- getLclEnv
+ ; return (map (lookup (tcl_env env)) ns) }
+ where
+ lookup lenv name
+ = case lookupNameEnv lenv name of
+ Just (ATcId { tct_id = id }) -> id
+ _ -> pprPanic "tcLookupLocalIds" (ppr name)
+
+-- inferInitialKind has made a suitably-shaped kind for the type or class
+-- Look it up in the local environment. This is used only for tycons
+-- that we're currently type-checking, so we're sure to find a TcTyCon.
+tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TcTyCon
+tcLookupTcTyCon name = do
+ thing <- tcLookup name
+ case thing of
+ ATcTyCon tc -> return tc
+ _ -> pprPanic "tcLookupTcTyCon" (ppr name)
+
+getInLocalScope :: TcM (Name -> Bool)
+getInLocalScope = do { lcl_env <- getLclTypeEnv
+ ; return (`elemNameEnv` lcl_env) }
+
+tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r
+-- Used only during kind checking, for TcThings that are
+-- ATcTyCon or APromotionErr
+-- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr
+tcExtendKindEnvList things thing_inside
+ = do { traceTc "tcExtendKindEnvList" (ppr things)
+ ; updLclEnv upd_env thing_inside }
+ where
+ upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things }
+
+tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r
+-- A variant of tcExtendKindEvnList
+tcExtendKindEnv extra_env thing_inside
+ = do { traceTc "tcExtendKindEnv" (ppr extra_env)
+ ; updLclEnv upd_env thing_inside }
+ where
+ upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env }
+
+-----------------------
+-- Scoped type and kind variables
+tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
+tcExtendTyVarEnv tvs thing_inside
+ = tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside
+
+tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r
+tcExtendNameTyVarEnv binds thing_inside
+ -- this should be used only for explicitly mentioned scoped variables.
+ -- thus, no coercion variables
+ = do { tc_extend_local_env NotTopLevel
+ [(name, ATyVar name tv) | (name, tv) <- binds] $
+ tcExtendBinderStack tv_binds $
+ thing_inside }
+ where
+ tv_binds :: [TcBinder]
+ tv_binds = [TcTvBndr name tv | (name,tv) <- binds]
+
+isTypeClosedLetBndr :: Id -> Bool
+-- See Note [Bindings with closed types] in GHC.Tc.Types
+isTypeClosedLetBndr = noFreeVarsOfType . idType
+
+tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a
+-- Used for binding the recursive uses of Ids in a binding
+-- both top-level value bindings and nested let/where-bindings
+-- Does not extend the TcBinderStack
+tcExtendRecIds pairs thing_inside
+ = tc_extend_local_env NotTopLevel
+ [ (name, ATcId { tct_id = let_id
+ , tct_info = NonClosedLet emptyNameSet False })
+ | (name, let_id) <- pairs ] $
+ thing_inside
+
+tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
+-- Used for binding the Ids that have a complete user type signature
+-- Does not extend the TcBinderStack
+tcExtendSigIds top_lvl sig_ids thing_inside
+ = tc_extend_local_env top_lvl
+ [ (idName id, ATcId { tct_id = id
+ , tct_info = info })
+ | id <- sig_ids
+ , let closed = isTypeClosedLetBndr id
+ info = NonClosedLet emptyNameSet closed ]
+ thing_inside
+
+
+tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed
+ -> [TcId] -> TcM a -> TcM a
+-- Used for both top-level value bindings and nested let/where-bindings
+-- Adds to the TcBinderStack too
+tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed)
+ ids thing_inside
+ = tcExtendBinderStack [TcIdBndr id top_lvl | id <- ids] $
+ tc_extend_local_env top_lvl
+ [ (idName id, ATcId { tct_id = id
+ , tct_info = mk_tct_info id })
+ | id <- ids ]
+ thing_inside
+ where
+ mk_tct_info id
+ | type_closed && isEmptyNameSet rhs_fvs = ClosedLet
+ | otherwise = NonClosedLet rhs_fvs type_closed
+ where
+ name = idName id
+ rhs_fvs = lookupNameEnv fvs name `orElse` emptyNameSet
+ type_closed = isTypeClosedLetBndr id &&
+ (fv_type_closed || hasCompleteSig sig_fn name)
+
+tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
+-- For lambda-bound and case-bound Ids
+-- Extends the TcBinderStack as well
+tcExtendIdEnv ids thing_inside
+ = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
+
+tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
+-- Exactly like tcExtendIdEnv2, but for a single (name,id) pair
+tcExtendIdEnv1 name id thing_inside
+ = tcExtendIdEnv2 [(name,id)] thing_inside
+
+tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
+tcExtendIdEnv2 names_w_ids thing_inside
+ = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel
+ | (_,mono_id) <- names_w_ids ] $
+ tc_extend_local_env NotTopLevel
+ [ (name, ATcId { tct_id = id
+ , tct_info = NotLetBound })
+ | (name,id) <- names_w_ids]
+ thing_inside
+
+tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
+tc_extend_local_env top_lvl extra_env thing_inside
+-- Precondition: the argument list extra_env has TcTyThings
+-- that ATcId or ATyVar, but nothing else
+--
+-- Invariant: the ATcIds are fully zonked. Reasons:
+-- (a) The kinds of the forall'd type variables are defaulted
+-- (see Kind.defaultKind, done in skolemiseQuantifiedTyVar)
+-- (b) There are no via-Indirect occurrences of the bound variables
+-- in the types, because instantiation does not look through such things
+-- (c) The call to tyCoVarsOfTypes is ok without looking through refs
+
+-- The second argument of type TyVarSet is a set of type variables
+-- that are bound together with extra_env and should not be regarded
+-- as free in the types of extra_env.
+ = do { traceTc "tc_extend_local_env" (ppr extra_env)
+ ; env0 <- getLclEnv
+ ; let env1 = tcExtendLocalTypeEnv env0 extra_env
+ ; stage <- getStage
+ ; let env2 = extend_local_env (top_lvl, thLevel stage) extra_env env1
+ ; setLclEnv env2 thing_inside }
+ where
+ extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv
+ -- Extend the local LocalRdrEnv and Template Haskell staging env simultaneously
+ -- Reason for extending LocalRdrEnv: after running a TH splice we need
+ -- to do renaming.
+ extend_local_env thlvl pairs env@(TcLclEnv { tcl_rdr = rdr_env
+ , tcl_th_bndrs = th_bndrs })
+ = env { tcl_rdr = extendLocalRdrEnvList rdr_env
+ [ n | (n, _) <- pairs, isInternalName n ]
+ -- The LocalRdrEnv contains only non-top-level names
+ -- (GlobalRdrEnv handles the top level)
+ , tcl_th_bndrs = extendNameEnvList th_bndrs -- We only track Ids in tcl_th_bndrs
+ [(n, thlvl) | (n, ATcId {}) <- pairs] }
+
+tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv
+tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things
+ = lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things }
+
+{- *********************************************************************
+* *
+ The TcBinderStack
+* *
+********************************************************************* -}
+
+tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a
+tcExtendBinderStack bndrs thing_inside
+ = do { traceTc "tcExtendBinderStack" (ppr bndrs)
+ ; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env })
+ thing_inside }
+
+tcInitTidyEnv :: TcM TidyEnv
+-- We initialise the "tidy-env", used for tidying types before printing,
+-- by building a reverse map from the in-scope type variables to the
+-- OccName that the programmer originally used for them
+tcInitTidyEnv
+ = do { lcl_env <- getLclEnv
+ ; go emptyTidyEnv (tcl_bndrs lcl_env) }
+ where
+ go (env, subst) []
+ = return (env, subst)
+ go (env, subst) (b : bs)
+ | TcTvBndr name tyvar <- b
+ = do { let (env', occ') = tidyOccName env (nameOccName name)
+ name' = tidyNameOcc name occ'
+ tyvar1 = setTyVarName tyvar name'
+ ; tyvar2 <- zonkTcTyVarToTyVar tyvar1
+ -- Be sure to zonk here! Tidying applies to zonked
+ -- types, so if we don't zonk we may create an
+ -- ill-kinded type (#14175)
+ ; go (env', extendVarEnv subst tyvar tyvar2) bs }
+ | otherwise
+ = go (env, subst) bs
+
+-- | Get a 'TidyEnv' that includes mappings for all vars free in the given
+-- type. Useful when tidying open types.
+tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
+tcInitOpenTidyEnv tvs
+ = do { env1 <- tcInitTidyEnv
+ ; let env2 = tidyFreeTyCoVars env1 tvs
+ ; return env2 }
+
+
+
+{- *********************************************************************
+* *
+ Adding placeholders
+* *
+********************************************************************* -}
+
+tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a
+-- See Note [AFamDataCon: not promoting data family constructors]
+tcAddDataFamConPlaceholders inst_decls thing_inside
+ = tcExtendKindEnvList [ (con, APromotionErr FamDataConPE)
+ | lid <- inst_decls, con <- get_cons lid ]
+ thing_inside
+ -- Note [AFamDataCon: not promoting data family constructors]
+ where
+ -- get_cons extracts the *constructor* bindings of the declaration
+ get_cons :: LInstDecl GhcRn -> [Name]
+ get_cons (L _ (TyFamInstD {})) = []
+ get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid
+ get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
+ = concatMap (get_fi_cons . unLoc) fids
+ get_cons (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec
+ get_cons (L _ (XInstDecl nec)) = noExtCon nec
+
+ get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
+ get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+ FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}})
+ = map unLoc $ concatMap (getConNames . unLoc) cons
+ get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+ FamEqn { feqn_rhs = XHsDataDefn nec }}})
+ = noExtCon nec
+ get_fi_cons (DataFamInstDecl (HsIB _ (XFamEqn nec))) = noExtCon nec
+ get_fi_cons (DataFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec
+
+
+tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
+-- See Note [Don't promote pattern synonyms]
+tcAddPatSynPlaceholders pat_syns thing_inside
+ = tcExtendKindEnvList [ (name, APromotionErr PatSynPE)
+ | PSB{ psb_id = L _ name } <- pat_syns ]
+ thing_inside
+
+getTypeSigNames :: [LSig GhcRn] -> NameSet
+-- Get the names that have a user type sig
+getTypeSigNames sigs
+ = foldr get_type_sig emptyNameSet sigs
+ where
+ get_type_sig :: LSig GhcRn -> NameSet -> NameSet
+ get_type_sig sig ns =
+ case sig of
+ L _ (TypeSig _ names _) -> extendNameSetList ns (map unLoc names)
+ L _ (PatSynSig _ names _) -> extendNameSetList ns (map unLoc names)
+ _ -> ns
+
+
+{- Note [AFamDataCon: not promoting data family constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ data family T a
+ data instance T Int = MkT
+ data Proxy (a :: k)
+ data S = MkS (Proxy 'MkT)
+
+Is it ok to use the promoted data family instance constructor 'MkT' in
+the data declaration for S (where both declarations live in the same module)?
+No, we don't allow this. It *might* make sense, but at least it would mean that
+we'd have to interleave typechecking instances and data types, whereas at
+present we do data types *then* instances.
+
+So to check for this we put in the TcLclEnv a binding for all the family
+constructors, bound to AFamDataCon, so that if we trip over 'MkT' when
+type checking 'S' we'll produce a decent error message.
+
+#12088 describes this limitation. Of course, when MkT and S live in
+different modules then all is well.
+
+Note [Don't promote pattern synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We never promote pattern synonyms.
+
+Consider this (#11265):
+ pattern A = True
+ instance Eq A
+We want a civilised error message from the occurrence of 'A'
+in the instance, yet 'A' really has not yet been type checked.
+
+Similarly (#9161)
+ {-# LANGUAGE PatternSynonyms, DataKinds #-}
+ pattern A = ()
+ b :: A
+ b = undefined
+Here, the type signature for b mentions A. But A is a pattern
+synonym, which is typechecked as part of a group of bindings (for very
+good reasons; a view pattern in the RHS may mention a value binding).
+It is entirely reasonable to reject this, but to do so we need A to be
+in the kind environment when kind-checking the signature for B.
+
+Hence tcAddPatSynPlaceholers adds a binding
+ A -> APromotionErr PatSynPE
+to the environment. Then GHC.Tc.Gen.HsType.tcTyVar will find A in the kind
+environment, and will give a 'wrongThingErr' as a result. But the
+lookup of A won't fail.
+
+
+************************************************************************
+* *
+\subsection{Rules}
+* *
+************************************************************************
+-}
+
+tcExtendRules :: [LRuleDecl GhcTc] -> TcM a -> TcM a
+ -- Just pop the new rules into the EPS and envt resp
+ -- All the rules come from an interface file, not source
+ -- Nevertheless, some may be for this module, if we read
+ -- its interface instead of its source code
+tcExtendRules lcl_rules thing_inside
+ = do { env <- getGblEnv
+ ; let
+ env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
+ ; setGblEnv env' thing_inside }
+
+{-
+************************************************************************
+* *
+ Meta level
+* *
+************************************************************************
+-}
+
+checkWellStaged :: SDoc -- What the stage check is for
+ -> ThLevel -- Binding level (increases inside brackets)
+ -> ThLevel -- Use stage
+ -> TcM () -- Fail if badly staged, adding an error
+checkWellStaged pp_thing bind_lvl use_lvl
+ | use_lvl >= bind_lvl -- OK! Used later than bound
+ = return () -- E.g. \x -> [| $(f x) |]
+
+ | bind_lvl == outerLevel -- GHC restriction on top level splices
+ = stageRestrictionError pp_thing
+
+ | otherwise -- Badly staged
+ = failWithTc $ -- E.g. \x -> $(f x)
+ text "Stage error:" <+> pp_thing <+>
+ hsep [text "is bound at stage" <+> ppr bind_lvl,
+ text "but used at stage" <+> ppr use_lvl]
+
+stageRestrictionError :: SDoc -> TcM a
+stageRestrictionError pp_thing
+ = failWithTc $
+ sep [ text "GHC stage restriction:"
+ , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation,"
+ , text "and must be imported, not defined locally"])]
+
+topIdLvl :: Id -> ThLevel
+-- Globals may either be imported, or may be from an earlier "chunk"
+-- (separated by declaration splices) of this module. The former
+-- *can* be used inside a top-level splice, but the latter cannot.
+-- Hence we give the former impLevel, but the latter topLevel
+-- E.g. this is bad:
+-- x = [| foo |]
+-- $( f x )
+-- By the time we are processing the $(f x), the binding for "x"
+-- will be in the global env, not the local one.
+topIdLvl id | isLocalId id = outerLevel
+ | otherwise = impLevel
+
+tcMetaTy :: Name -> TcM Type
+-- Given the name of a Template Haskell data type,
+-- return the type
+-- E.g. given the name "Expr" return the type "Expr"
+tcMetaTy tc_name = do
+ t <- tcLookupTyCon tc_name
+ return (mkTyConTy t)
+
+isBrackStage :: ThStage -> Bool
+isBrackStage (Brack {}) = True
+isBrackStage _other = False
+
+{-
+************************************************************************
+* *
+ getDefaultTys
+* *
+************************************************************************
+-}
+
+tcGetDefaultTys :: TcM ([Type], -- Default types
+ (Bool, -- True <=> Use overloaded strings
+ Bool)) -- True <=> Use extended defaulting rules
+tcGetDefaultTys
+ = do { dflags <- getDynFlags
+ ; let ovl_strings = xopt LangExt.OverloadedStrings dflags
+ extended_defaults = xopt LangExt.ExtendedDefaultRules dflags
+ -- See also #1974
+ flags = (ovl_strings, extended_defaults)
+
+ ; mb_defaults <- getDeclaredDefaultTys
+ ; case mb_defaults of {
+ Just tys -> return (tys, flags) ;
+ -- User-supplied defaults
+ Nothing -> do
+
+ -- No use-supplied default
+ -- Use [Integer, Double], plus modifications
+ { integer_ty <- tcMetaTy integerTyConName
+ ; list_ty <- tcMetaTy listTyConName
+ ; checkWiredInTyCon doubleTyCon
+ ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty]
+ -- Note [Extended defaults]
+ ++ [integer_ty, doubleTy]
+ ++ opt_deflt ovl_strings [stringTy]
+ ; return (deflt_tys, flags) } } }
+ where
+ opt_deflt True xs = xs
+ opt_deflt False _ = []
+
+{-
+Note [Extended defaults]
+~~~~~~~~~~~~~~~~~~~~~
+In interactive mode (or with -XExtendedDefaultRules) we add () as the first type we
+try when defaulting. This has very little real impact, except in the following case.
+Consider:
+ Text.Printf.printf "hello"
+This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't
+want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to
+default the 'a' to (), rather than to Integer (which is what would otherwise happen;
+and then GHCi doesn't attempt to print the (). So in interactive mode, we add
+() to the list of defaulting types. See #1200.
+
+Additionally, the list type [] is added as a default specialization for
+Traversable and Foldable. As such the default default list now has types of
+varying kinds, e.g. ([] :: * -> *) and (Integer :: *).
+
+************************************************************************
+* *
+\subsection{The InstInfo type}
+* *
+************************************************************************
+
+The InstInfo type summarises the information in an instance declaration
+
+ instance c => k (t tvs) where b
+
+It is used just for *local* instance decls (not ones from interface files).
+But local instance decls includes
+ - derived ones
+ - generic ones
+as well as explicit user written ones.
+-}
+
+data InstInfo a
+ = InstInfo
+ { iSpec :: ClsInst -- Includes the dfun id
+ , iBinds :: InstBindings a
+ }
+
+iDFunId :: InstInfo a -> DFunId
+iDFunId info = instanceDFunId (iSpec info)
+
+data InstBindings a
+ = InstBindings
+ { ib_tyvars :: [Name] -- Names of the tyvars from the instance head
+ -- that are lexically in scope in the bindings
+ -- Must correspond 1-1 with the forall'd tyvars
+ -- of the dfun Id. When typechecking, we are
+ -- going to extend the typechecker's envt with
+ -- ib_tyvars -> dfun_forall_tyvars
+
+ , ib_binds :: LHsBinds a -- Bindings for the instance methods
+
+ , ib_pragmas :: [LSig a] -- User pragmas recorded for generating
+ -- specialised instances
+
+ , ib_extensions :: [LangExt.Extension] -- Any extra extensions that should
+ -- be enabled when type-checking
+ -- this instance; needed for
+ -- GeneralizedNewtypeDeriving
+
+ , ib_derived :: Bool
+ -- True <=> This code was generated by GHC from a deriving clause
+ -- or standalone deriving declaration
+ -- Used only to improve error messages
+ }
+
+instance (OutputableBndrId a)
+ => Outputable (InstInfo (GhcPass a)) where
+ ppr = pprInstInfoDetails
+
+pprInstInfoDetails :: (OutputableBndrId a)
+ => InstInfo (GhcPass a) -> SDoc
+pprInstInfoDetails info
+ = hang (pprInstanceHdr (iSpec info) <+> text "where")
+ 2 (details (iBinds info))
+ where
+ details (InstBindings { ib_pragmas = p, ib_binds = b }) =
+ pprDeclList (pprLHsBindsForUser b p)
+
+simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
+simpleInstInfoClsTy info = case instanceHead (iSpec info) of
+ (_, cls, [ty]) -> (cls, ty)
+ _ -> panic "simpleInstInfoClsTy"
+
+simpleInstInfoTy :: InstInfo a -> Type
+simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
+
+simpleInstInfoTyCon :: InstInfo a -> TyCon
+ -- Gets the type constructor for a simple instance declaration,
+ -- i.e. one of the form instance (...) => C (T a b c) where ...
+simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
+
+-- | Make a name for the dict fun for an instance decl. It's an *external*
+-- name, like other top-level names, and hence must be made with
+-- newGlobalBinder.
+newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
+newDFunName clas tys loc
+ = do { is_boot <- tcIsHsBootOrSig
+ ; mod <- getModule
+ ; let info_string = occNameString (getOccName clas) ++
+ concatMap (occNameString.getDFunTyKey) tys
+ ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
+ ; newGlobalBinder mod dfun_occ loc }
+
+newFamInstTyConName :: Located Name -> [Type] -> TcM Name
+newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys]
+
+newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name
+newFamInstAxiomName (L loc name) branches
+ = mk_fam_inst_name mkInstTyCoOcc loc name branches
+
+mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
+mk_fam_inst_name adaptOcc loc tc_name tyss
+ = do { mod <- getModule
+ ; let info_string = occNameString (getOccName tc_name) ++
+ intercalate "|" ty_strings
+ ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
+ ; newGlobalBinder mod (adaptOcc occ) loc }
+ where
+ ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss
+
+{-
+Stable names used for foreign exports and annotations.
+For stable names, the name must be unique (see #1533). If the
+same thing has several stable Ids based on it, the
+top-level bindings generated must not have the same name.
+Hence we create an External name (doesn't change), and we
+append a Unique to the string right here.
+-}
+
+mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
+mkStableIdFromString str sig_ty loc occ_wrapper = do
+ uniq <- newUnique
+ mod <- getModule
+ name <- mkWrapperName "stable" str
+ let occ = mkVarOccFS name :: OccName
+ gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name
+ id = mkExportedVanillaId gnm sig_ty :: Id
+ return id
+
+mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
+mkStableIdFromName nm = mkStableIdFromString (getOccString nm)
+
+mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m)
+ => String -> String -> m FastString
+mkWrapperName what nameBase
+ = do dflags <- getDynFlags
+ thisMod <- getModule
+ let -- Note [Generating fresh names for ccall wrapper]
+ wrapperRef = nextWrapperNum dflags
+ pkg = unitIdString (moduleUnitId thisMod)
+ mod = moduleNameString (moduleName thisMod)
+ wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->
+ let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
+ mod_env' = extendModuleEnv mod_env thisMod (num+1)
+ in (mod_env', num)
+ let components = [what, show wrapperNum, pkg, mod, nameBase]
+ return $ mkFastString $ zEncodeString $ intercalate ":" components
+
+{-
+Note [Generating fresh names for FFI wrappers]
+
+We used to use a unique, rather than nextWrapperNum, to distinguish
+between FFI wrapper functions. However, the wrapper names that we
+generate are external names. This means that if a call to them ends up
+in an unfolding, then we can't alpha-rename them, and thus if the
+unique randomly changes from one compile to another then we get a
+spurious ABI change (#4012).
+
+The wrapper counter has to be per-module, not global, so that the number we end
+up using is not dependent on the modules compiled before the current one.
+-}
+
+{-
+************************************************************************
+* *
+\subsection{Errors}
+* *
+************************************************************************
+-}
+
+pprBinders :: [Name] -> SDoc
+-- Used in error messages
+-- Use quotes for a single one; they look a bit "busy" for several
+pprBinders [bndr] = quotes (ppr bndr)
+pprBinders bndrs = pprWithCommas ppr bndrs
+
+notFound :: Name -> TcM TyThing
+notFound name
+ = do { lcl_env <- getLclEnv
+ ; let stage = tcl_th_ctxt lcl_env
+ ; case stage of -- See Note [Out of scope might be a staging error]
+ Splice {}
+ | isUnboundName name -> failM -- If the name really isn't in scope
+ -- don't report it again (#11941)
+ | otherwise -> stageRestrictionError (quotes (ppr name))
+ _ -> failWithTc $
+ vcat[text "GHC internal error:" <+> quotes (ppr name) <+>
+ text "is not in scope during type checking, but it passed the renamer",
+ text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)]
+ -- Take care: printing the whole gbl env can
+ -- cause an infinite loop, in the case where we
+ -- are in the middle of a recursive TyCon/Class group;
+ -- so let's just not print it! Getting a loop here is
+ -- very unhelpful, because it hides one compiler bug with another
+ }
+
+wrongThingErr :: String -> TcTyThing -> Name -> TcM a
+-- It's important that this only calls pprTcTyThingCategory, which in
+-- turn does not look at the details of the TcTyThing.
+-- See Note [Placeholder PatSyn kinds] in GHC.Tc.Gen.Bind
+wrongThingErr expected thing name
+ = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
+ text "used as a" <+> text expected)
+
+{- Note [Out of scope might be a staging error]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ x = 3
+ data T = MkT $(foo x)
+
+where 'foo' is imported from somewhere.
+
+This is really a staging error, because we can't run code involving 'x'.
+But in fact the type checker processes types first, so 'x' won't even be
+in the type envt when we look for it in $(foo x). So inside splices we
+report something missing from the type env as a staging error.
+See #5752 and #5795.
+-}
diff --git a/compiler/GHC/Tc/Utils/Env.hs-boot b/compiler/GHC/Tc/Utils/Env.hs-boot
new file mode 100644
index 0000000000..7b1cde3c7d
--- /dev/null
+++ b/compiler/GHC/Tc/Utils/Env.hs-boot
@@ -0,0 +1,10 @@
+module GHC.Tc.Utils.Env where
+
+import GHC.Tc.Types( TcM )
+import GHC.Types.Var.Env( TidyEnv )
+
+-- Annoyingly, there's a recursion between tcInitTidyEnv
+-- (which does zonking and hence needs GHC.Tc.Utils.TcMType) and
+-- addErrTc etc which live in GHC.Tc.Utils.Monad. Rats.
+tcInitTidyEnv :: TcM TidyEnv
+
diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs
new file mode 100644
index 0000000000..74115d15b0
--- /dev/null
+++ b/compiler/GHC/Tc/Utils/Instantiate.hs
@@ -0,0 +1,852 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+-}
+
+{-# LANGUAGE CPP, MultiWayIf, TupleSections #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+
+-- | The @Inst@ type: dictionaries or method instances
+module GHC.Tc.Utils.Instantiate (
+ deeplySkolemise,
+ topInstantiate, topInstantiateInferred, deeplyInstantiate,
+ instCall, instDFunType, instStupidTheta, instTyVarsWith,
+ newWanted, newWanteds,
+
+ tcInstInvisibleTyBinders, tcInstInvisibleTyBinder,
+
+ newOverloadedLit, mkOverLit,
+
+ newClsInst,
+ tcGetInsts, tcGetInstEnvs, getOverlapFlag,
+ tcExtendLocalInstEnv,
+ instCallConstraints, newMethodFromName,
+ tcSyntaxName,
+
+ -- Simple functions over evidence variables
+ tyCoVarsOfWC,
+ tyCoVarsOfCt, tyCoVarsOfCts,
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr, tcSyntaxOp )
+import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType, unifyKind )
+
+import GHC.Types.Basic ( IntegralLit(..), SourceText(..) )
+import FastString
+import GHC.Hs
+import GHC.Tc.Utils.Zonk
+import GHC.Tc.Utils.Monad
+import GHC.Tc.Types.Constraint
+import GHC.Core.Predicate
+import GHC.Tc.Types.Origin
+import GHC.Tc.Utils.Env
+import GHC.Tc.Types.Evidence
+import GHC.Core.InstEnv
+import TysWiredIn ( heqDataCon, eqDataCon )
+import GHC.Core ( isOrphan )
+import GHC.Tc.Instance.FunDeps
+import GHC.Tc.Utils.TcMType
+import GHC.Core.Type
+import GHC.Core.TyCo.Rep
+import GHC.Core.TyCo.Ppr ( debugPprType )
+import GHC.Tc.Utils.TcType
+import GHC.Driver.Types
+import GHC.Core.Class( Class )
+import GHC.Types.Id.Make( mkDictFunId )
+import GHC.Core( Expr(..) ) -- For the Coercion constructor
+import GHC.Types.Id
+import GHC.Types.Name
+import GHC.Types.Var ( EvVar, tyVarName, VarBndr(..) )
+import GHC.Core.DataCon
+import GHC.Types.Var.Env
+import PrelNames
+import GHC.Types.SrcLoc as SrcLoc
+import GHC.Driver.Session
+import Util
+import Outputable
+import GHC.Types.Basic ( TypeOrKind(..) )
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.List ( sortBy )
+import Control.Monad( unless )
+import Data.Function ( on )
+
+{-
+************************************************************************
+* *
+ Creating and emittind constraints
+* *
+************************************************************************
+-}
+
+newMethodFromName
+ :: CtOrigin -- ^ why do we need this?
+ -> Name -- ^ name of the method
+ -> [TcRhoType] -- ^ types with which to instantiate the class
+ -> TcM (HsExpr GhcTcId)
+-- ^ Used when 'Name' is the wired-in name for a wired-in class method,
+-- so the caller knows its type for sure, which should be of form
+--
+-- > forall a. C a => <blah>
+--
+-- 'newMethodFromName' is supposed to instantiate just the outer
+-- type variable and constraint
+
+newMethodFromName origin name ty_args
+ = do { id <- tcLookupId name
+ -- Use tcLookupId not tcLookupGlobalId; the method is almost
+ -- always a class op, but with -XRebindableSyntax GHC is
+ -- meant to find whatever thing is in scope, and that may
+ -- be an ordinary function.
+
+ ; let ty = piResultTys (idType id) ty_args
+ (theta, _caller_knows_this) = tcSplitPhiTy ty
+ ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )
+ instCall origin ty_args theta
+
+ ; return (mkHsWrap wrap (HsVar noExtField (noLoc id))) }
+
+{-
+************************************************************************
+* *
+ Deep instantiation and skolemisation
+* *
+************************************************************************
+
+Note [Deep skolemisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+deeplySkolemise decomposes and skolemises a type, returning a type
+with all its arrows visible (ie not buried under foralls)
+
+Examples:
+
+ deeplySkolemise (Int -> forall a. Ord a => blah)
+ = ( wp, [a], [d:Ord a], Int -> blah )
+ where wp = \x:Int. /\a. \(d:Ord a). <hole> x
+
+ deeplySkolemise (forall a. Ord a => Maybe a -> forall b. Eq b => blah)
+ = ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah )
+ where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x
+
+In general,
+ if deeplySkolemise ty = (wrap, tvs, evs, rho)
+ and e :: rho
+ then wrap e :: ty
+ and 'wrap' binds tvs, evs
+
+ToDo: this eta-abstraction plays fast and loose with termination,
+ because it can introduce extra lambdas. Maybe add a `seq` to
+ fix this
+-}
+
+deeplySkolemise :: TcSigmaType
+ -> TcM ( HsWrapper
+ , [(Name,TyVar)] -- All skolemised variables
+ , [EvVar] -- All "given"s
+ , TcRhoType )
+
+deeplySkolemise ty
+ = go init_subst ty
+ where
+ init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))
+
+ go subst ty
+ | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
+ = do { let arg_tys' = substTys subst arg_tys
+ ; ids1 <- newSysLocalIds (fsLit "dk") arg_tys'
+ ; (subst', tvs1) <- tcInstSkolTyVarsX subst tvs
+ ; ev_vars1 <- newEvVars (substTheta subst' theta)
+ ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty'
+ ; let tv_prs1 = map tyVarName tvs `zip` tvs1
+ ; return ( mkWpLams ids1
+ <.> mkWpTyLams tvs1
+ <.> mkWpLams ev_vars1
+ <.> wrap
+ <.> mkWpEvVarApps ids1
+ , tv_prs1 ++ tvs_prs2
+ , ev_vars1 ++ ev_vars2
+ , mkVisFunTys arg_tys' rho ) }
+
+ | otherwise
+ = return (idHsWrapper, [], [], substTy subst ty)
+ -- substTy is a quick no-op on an empty substitution
+
+-- | Instantiate all outer type variables
+-- and any context. Never looks through arrows.
+topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
+-- if topInstantiate ty = (wrap, rho)
+-- and e :: ty
+-- then wrap e :: rho (that is, wrap :: ty "->" rho)
+topInstantiate = top_instantiate True
+
+-- | Instantiate all outer 'Inferred' binders
+-- and any context. Never looks through arrows or specified type variables.
+-- Used for visible type application.
+topInstantiateInferred :: CtOrigin -> TcSigmaType
+ -> TcM (HsWrapper, TcSigmaType)
+-- if topInstantiate ty = (wrap, rho)
+-- and e :: ty
+-- then wrap e :: rho
+topInstantiateInferred = top_instantiate False
+
+top_instantiate :: Bool -- True <=> instantiate *all* variables
+ -- False <=> instantiate only the inferred ones
+ -> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
+top_instantiate inst_all orig ty
+ | not (null binders && null theta)
+ = do { let (inst_bndrs, leave_bndrs) = span should_inst binders
+ (inst_theta, leave_theta)
+ | null leave_bndrs = (theta, [])
+ | otherwise = ([], theta)
+ in_scope = mkInScopeSet (tyCoVarsOfType ty)
+ empty_subst = mkEmptyTCvSubst in_scope
+ inst_tvs = binderVars inst_bndrs
+ ; (subst, inst_tvs') <- mapAccumLM newMetaTyVarX empty_subst inst_tvs
+ ; let inst_theta' = substTheta subst inst_theta
+ sigma' = substTy subst (mkForAllTys leave_bndrs $
+ mkPhiTy leave_theta rho)
+ inst_tv_tys' = mkTyVarTys inst_tvs'
+
+ ; wrap1 <- instCall orig inst_tv_tys' inst_theta'
+ ; traceTc "Instantiating"
+ (vcat [ text "all tyvars?" <+> ppr inst_all
+ , text "origin" <+> pprCtOrigin orig
+ , text "type" <+> debugPprType ty
+ , text "theta" <+> ppr theta
+ , text "leave_bndrs" <+> ppr leave_bndrs
+ , text "with" <+> vcat (map debugPprType inst_tv_tys')
+ , text "theta:" <+> ppr inst_theta' ])
+
+ ; (wrap2, rho2) <-
+ if null leave_bndrs
+
+ -- account for types like forall a. Num a => forall b. Ord b => ...
+ then top_instantiate inst_all orig sigma'
+
+ -- but don't loop if there were any un-inst'able tyvars
+ else return (idHsWrapper, sigma')
+
+ ; return (wrap2 <.> wrap1, rho2) }
+
+ | otherwise = return (idHsWrapper, ty)
+ where
+ (binders, phi) = tcSplitForAllVarBndrs ty
+ (theta, rho) = tcSplitPhiTy phi
+
+ should_inst bndr
+ | inst_all = True
+ | otherwise = binderArgFlag bndr == Inferred
+
+deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
+-- Int -> forall a. a -> a ==> (\x:Int. [] x alpha) :: Int -> alpha
+-- In general if
+-- if deeplyInstantiate ty = (wrap, rho)
+-- and e :: ty
+-- then wrap e :: rho
+-- That is, wrap :: ty ~> rho
+--
+-- If you don't need the HsWrapper returned from this function, consider
+-- using tcSplitNestedSigmaTys in GHC.Tc.Utils.TcType, which is a pure alternative that
+-- only computes the returned TcRhoType.
+
+deeplyInstantiate orig ty =
+ deeply_instantiate orig
+ (mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)))
+ ty
+
+deeply_instantiate :: CtOrigin
+ -> TCvSubst
+ -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
+-- Internal function to deeply instantiate that builds on an existing subst.
+-- It extends the input substitution and applies the final substitution to
+-- the types on return. See #12549.
+
+deeply_instantiate orig subst ty
+ | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty
+ = do { (subst', tvs') <- newMetaTyVarsX subst tvs
+ ; let arg_tys' = substTys subst' arg_tys
+ theta' = substTheta subst' theta
+ ; ids1 <- newSysLocalIds (fsLit "di") arg_tys'
+ ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'
+ ; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig
+ , text "type" <+> ppr ty
+ , text "with" <+> ppr tvs'
+ , text "args:" <+> ppr ids1
+ , text "theta:" <+> ppr theta'
+ , text "subst:" <+> ppr subst'])
+ ; (wrap2, rho2) <- deeply_instantiate orig subst' rho
+ ; return (mkWpLams ids1
+ <.> wrap2
+ <.> wrap1
+ <.> mkWpEvVarApps ids1,
+ mkVisFunTys arg_tys' rho2) }
+
+ | otherwise
+ = do { let ty' = substTy subst ty
+ ; traceTc "deeply_instantiate final subst"
+ (vcat [ text "origin:" <+> pprCtOrigin orig
+ , text "type:" <+> ppr ty
+ , text "new type:" <+> ppr ty'
+ , text "subst:" <+> ppr subst ])
+ ; return (idHsWrapper, ty') }
+
+
+instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst
+-- Use this when you want to instantiate (forall a b c. ty) with
+-- types [ta, tb, tc], but when the kinds of 'a' and 'ta' might
+-- not yet match (perhaps because there are unsolved constraints; #14154)
+-- If they don't match, emit a kind-equality to promise that they will
+-- eventually do so, and thus make a kind-homongeneous substitution.
+instTyVarsWith orig tvs tys
+ = go emptyTCvSubst tvs tys
+ where
+ go subst [] []
+ = return subst
+ go subst (tv:tvs) (ty:tys)
+ | tv_kind `tcEqType` ty_kind
+ = go (extendTvSubstAndInScope subst tv ty) tvs tys
+ | otherwise
+ = do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind
+ ; go (extendTvSubstAndInScope subst tv (ty `mkCastTy` co)) tvs tys }
+ where
+ tv_kind = substTy subst (tyVarKind tv)
+ ty_kind = tcTypeKind ty
+
+ go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys)
+
+
+{-
+************************************************************************
+* *
+ Instantiating a call
+* *
+************************************************************************
+
+Note [Handling boxed equality]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The solver deals entirely in terms of unboxed (primitive) equality.
+There should never be a boxed Wanted equality. Ever. But, what if
+we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality
+is boxed, so naive treatment here would emit a boxed Wanted equality.
+
+So we simply check for this case and make the right boxing of evidence.
+
+-}
+
+----------------
+instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
+-- Instantiate the constraints of a call
+-- (instCall o tys theta)
+-- (a) Makes fresh dictionaries as necessary for the constraints (theta)
+-- (b) Throws these dictionaries into the LIE
+-- (c) Returns an HsWrapper ([.] tys dicts)
+
+instCall orig tys theta
+ = do { dict_app <- instCallConstraints orig theta
+ ; return (dict_app <.> mkWpTyApps tys) }
+
+----------------
+instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
+-- Instantiates the TcTheta, puts all constraints thereby generated
+-- into the LIE, and returns a HsWrapper to enclose the call site.
+
+instCallConstraints orig preds
+ | null preds
+ = return idHsWrapper
+ | otherwise
+ = do { evs <- mapM go preds
+ ; traceTc "instCallConstraints" (ppr evs)
+ ; return (mkWpEvApps evs) }
+ where
+ go :: TcPredType -> TcM EvTerm
+ go pred
+ | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1
+ = do { co <- unifyType Nothing ty1 ty2
+ ; return (evCoercion co) }
+
+ -- Try short-cut #2
+ | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred
+ , tc `hasKey` heqTyConKey
+ = do { co <- unifyType Nothing ty1 ty2
+ ; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) }
+
+ | otherwise
+ = emitWanted orig pred
+
+instDFunType :: DFunId -> [DFunInstType]
+ -> TcM ( [TcType] -- instantiated argument types
+ , TcThetaType ) -- instantiated constraint
+-- See Note [DFunInstType: instantiating types] in GHC.Core.InstEnv
+instDFunType dfun_id dfun_inst_tys
+ = do { (subst, inst_tys) <- go empty_subst dfun_tvs dfun_inst_tys
+ ; return (inst_tys, substTheta subst dfun_theta) }
+ where
+ dfun_ty = idType dfun_id
+ (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty
+ empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType dfun_ty))
+ -- With quantified constraints, the
+ -- type of a dfun may not be closed
+
+ go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType])
+ go subst [] [] = return (subst, [])
+ go subst (tv:tvs) (Just ty : mb_tys)
+ = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty)
+ tvs
+ mb_tys
+ ; return (subst', ty : tys) }
+ go subst (tv:tvs) (Nothing : mb_tys)
+ = do { (subst', tv') <- newMetaTyVarX subst tv
+ ; (subst'', tys) <- go subst' tvs mb_tys
+ ; return (subst'', mkTyVarTy tv' : tys) }
+ go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys)
+
+----------------
+instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
+-- Similar to instCall, but only emit the constraints in the LIE
+-- Used exclusively for the 'stupid theta' of a data constructor
+instStupidTheta orig theta
+ = do { _co <- instCallConstraints orig theta -- Discard the coercion
+ ; return () }
+
+
+{- *********************************************************************
+* *
+ Instantiating Kinds
+* *
+********************************************************************* -}
+
+-- | Instantiates up to n invisible binders
+-- Returns the instantiating types, and body kind
+tcInstInvisibleTyBinders :: Int -> TcKind -> TcM ([TcType], TcKind)
+
+tcInstInvisibleTyBinders 0 kind
+ = return ([], kind)
+tcInstInvisibleTyBinders n ty
+ = go n empty_subst ty
+ where
+ empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))
+
+ go n subst kind
+ | n > 0
+ , Just (bndr, body) <- tcSplitPiTy_maybe kind
+ , isInvisibleBinder bndr
+ = do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr
+ ; (args, inner_ty) <- go (n-1) subst' body
+ ; return (arg:args, inner_ty) }
+ | otherwise
+ = return ([], substTy subst kind)
+
+-- | Used only in *types*
+tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)
+tcInstInvisibleTyBinder subst (Named (Bndr tv _))
+ = do { (subst', tv') <- newMetaTyVarX subst tv
+ ; return (subst', mkTyVarTy tv') }
+
+tcInstInvisibleTyBinder subst (Anon af ty)
+ | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst ty)
+ -- Equality is the *only* constraint currently handled in types.
+ -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep
+ = ASSERT( af == InvisArg )
+ do { co <- unifyKind Nothing k1 k2
+ ; arg' <- mk co
+ ; return (subst, arg') }
+
+ | otherwise -- This should never happen
+ -- See GHC.Core.TyCo.Rep Note [Constraints in kinds]
+ = pprPanic "tcInvisibleTyBinder" (ppr ty)
+
+-------------------------------
+get_eq_tys_maybe :: Type
+ -> Maybe ( Coercion -> TcM Type
+ -- given a coercion proving t1 ~# t2, produce the
+ -- right instantiation for the TyBinder at hand
+ , Type -- t1
+ , Type -- t2
+ )
+-- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep
+get_eq_tys_maybe ty
+ -- Lifted heterogeneous equality (~~)
+ | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty
+ , tc `hasKey` heqTyConKey
+ = Just (\co -> mkHEqBoxTy co k1 k2, k1, k2)
+
+ -- Lifted homogeneous equality (~)
+ | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty
+ , tc `hasKey` eqTyConKey
+ = Just (\co -> mkEqBoxTy co k1 k2, k1, k2)
+
+ | otherwise
+ = Nothing
+
+-- | This takes @a ~# b@ and returns @a ~~ b@.
+mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
+-- monadic just for convenience with mkEqBoxTy
+mkHEqBoxTy co ty1 ty2
+ = return $
+ mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co]
+ where k1 = tcTypeKind ty1
+ k2 = tcTypeKind ty2
+
+-- | This takes @a ~# b@ and returns @a ~ b@.
+mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
+mkEqBoxTy co ty1 ty2
+ = return $
+ mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co]
+ where k = tcTypeKind ty1
+
+{-
+************************************************************************
+* *
+ Literals
+* *
+************************************************************************
+
+-}
+
+{-
+In newOverloadedLit we convert directly to an Int or Integer if we
+know that's what we want. This may save some time, by not
+temporarily generating overloaded literals, but it won't catch all
+cases (the rest are caught in lookupInst).
+
+-}
+
+newOverloadedLit :: HsOverLit GhcRn
+ -> ExpRhoType
+ -> TcM (HsOverLit GhcTcId)
+newOverloadedLit
+ lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty
+ | not rebindable
+ -- all built-in overloaded lits are tau-types, so we can just
+ -- tauify the ExpType
+ = do { res_ty <- expTypeToType res_ty
+ ; dflags <- getDynFlags
+ ; let platform = targetPlatform dflags
+ ; case shortCutLit platform val res_ty of
+ -- Do not generate a LitInst for rebindable syntax.
+ -- Reason: If we do, tcSimplify will call lookupInst, which
+ -- will call tcSyntaxName, which does unification,
+ -- which tcSimplify doesn't like
+ Just expr -> return (lit { ol_witness = expr
+ , ol_ext = OverLitTc False res_ty })
+ Nothing -> newNonTrivialOverloadedLit orig lit
+ (mkCheckExpType res_ty) }
+
+ | otherwise
+ = newNonTrivialOverloadedLit orig lit res_ty
+ where
+ orig = LiteralOrigin lit
+newOverloadedLit (XOverLit nec) _ = noExtCon nec
+
+-- Does not handle things that 'shortCutLit' can handle. See also
+-- newOverloadedLit in GHC.Tc.Utils.Unify
+newNonTrivialOverloadedLit :: CtOrigin
+ -> HsOverLit GhcRn
+ -> ExpRhoType
+ -> TcM (HsOverLit GhcTcId)
+newNonTrivialOverloadedLit orig
+ lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name)
+ , ol_ext = rebindable }) res_ty
+ = do { hs_lit <- mkOverLit val
+ ; let lit_ty = hsLitType hs_lit
+ ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)
+ [synKnownType lit_ty] res_ty $
+ \_ -> return ()
+ ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]
+ ; res_ty <- readExpType res_ty
+ ; return (lit { ol_witness = witness
+ , ol_ext = OverLitTc rebindable res_ty }) }
+newNonTrivialOverloadedLit _ lit _
+ = pprPanic "newNonTrivialOverloadedLit" (ppr lit)
+
+------------
+mkOverLit ::OverLitVal -> TcM (HsLit GhcTc)
+mkOverLit (HsIntegral i)
+ = do { integer_ty <- tcMetaTy integerTyConName
+ ; return (HsInteger (il_text i)
+ (il_value i) integer_ty) }
+
+mkOverLit (HsFractional r)
+ = do { rat_ty <- tcMetaTy rationalTyConName
+ ; return (HsRat noExtField r rat_ty) }
+
+mkOverLit (HsIsString src s) = return (HsString src s)
+
+{-
+************************************************************************
+* *
+ Re-mappable syntax
+
+ Used only for arrow syntax -- find a way to nuke this
+* *
+************************************************************************
+
+Suppose we are doing the -XRebindableSyntax thing, and we encounter
+a do-expression. We have to find (>>) in the current environment, which is
+done by the rename. Then we have to check that it has the same type as
+Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
+this:
+
+ (>>) :: HB m n mn => m a -> n b -> mn b
+
+So the idea is to generate a local binding for (>>), thus:
+
+ let then72 :: forall a b. m a -> m b -> m b
+ then72 = ...something involving the user's (>>)...
+ in
+ ...the do-expression...
+
+Now the do-expression can proceed using then72, which has exactly
+the expected type.
+
+In fact tcSyntaxName just generates the RHS for then72, because we only
+want an actual binding in the do-expression case. For literals, we can
+just use the expression inline.
+-}
+
+tcSyntaxName :: CtOrigin
+ -> TcType -- ^ Type to instantiate it at
+ -> (Name, HsExpr GhcRn) -- ^ (Standard name, user name)
+ -> TcM (Name, HsExpr GhcTcId)
+ -- ^ (Standard name, suitable expression)
+-- USED ONLY FOR CmdTop (sigh) ***
+-- See Note [CmdSyntaxTable] in GHC.Hs.Expr
+
+tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm))
+ | std_nm == user_nm
+ = do rhs <- newMethodFromName orig std_nm [ty]
+ return (std_nm, rhs)
+
+tcSyntaxName orig ty (std_nm, user_nm_expr) = do
+ std_id <- tcLookupId std_nm
+ let
+ -- C.f. newMethodAtLoc
+ ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
+ sigma1 = substTyWith [tv] [ty] tau
+ -- Actually, the "tau-type" might be a sigma-type in the
+ -- case of locally-polymorphic methods.
+
+ addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
+
+ -- Check that the user-supplied thing has the
+ -- same type as the standard one.
+ -- Tiresome jiggling because tcCheckSigma takes a located expression
+ span <- getSrcSpanM
+ expr <- tcPolyExpr (L span user_nm_expr) sigma1
+ return (std_nm, unLoc expr)
+
+syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv
+ -> TcRn (TidyEnv, SDoc)
+syntaxNameCtxt name orig ty tidy_env
+ = do { inst_loc <- getCtLocM orig (Just TypeLevel)
+ ; let msg = vcat [ text "When checking that" <+> quotes (ppr name)
+ <+> text "(needed by a syntactic construct)"
+ , nest 2 (text "has the required type:"
+ <+> ppr (tidyType tidy_env ty))
+ , nest 2 (pprCtLoc inst_loc) ]
+ ; return (tidy_env, msg) }
+
+{-
+************************************************************************
+* *
+ Instances
+* *
+************************************************************************
+-}
+
+getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
+-- Construct the OverlapFlag from the global module flags,
+-- but if the overlap_mode argument is (Just m),
+-- set the OverlapMode to 'm'
+getOverlapFlag overlap_mode
+ = do { dflags <- getDynFlags
+ ; let overlap_ok = xopt LangExt.OverlappingInstances dflags
+ incoherent_ok = xopt LangExt.IncoherentInstances dflags
+ use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
+ , overlapMode = x }
+ default_oflag | incoherent_ok = use (Incoherent NoSourceText)
+ | overlap_ok = use (Overlaps NoSourceText)
+ | otherwise = use (NoOverlap NoSourceText)
+
+ final_oflag = setOverlapModeMaybe default_oflag overlap_mode
+ ; return final_oflag }
+
+tcGetInsts :: TcM [ClsInst]
+-- Gets the local class instances.
+tcGetInsts = fmap tcg_insts getGblEnv
+
+newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
+ -> Class -> [Type] -> TcM ClsInst
+newClsInst overlap_mode dfun_name tvs theta clas tys
+ = do { (subst, tvs') <- freshenTyVarBndrs tvs
+ -- Be sure to freshen those type variables,
+ -- so they are sure not to appear in any lookup
+ ; let tys' = substTys subst tys
+
+ dfun = mkDictFunId dfun_name tvs theta clas tys
+ -- The dfun uses the original 'tvs' because
+ -- (a) they don't need to be fresh
+ -- (b) they may be mentioned in the ib_binds field of
+ -- an InstInfo, and in GHC.Tc.Utils.Env.pprInstInfoDetails it's
+ -- helpful to use the same names
+
+ ; oflag <- getOverlapFlag overlap_mode
+ ; let inst = mkLocalInstance dfun oflag tvs' clas tys'
+ ; warnIfFlag Opt_WarnOrphans
+ (isOrphan (is_orphan inst))
+ (instOrphWarn inst)
+ ; return inst }
+
+instOrphWarn :: ClsInst -> SDoc
+instOrphWarn inst
+ = hang (text "Orphan instance:") 2 (pprInstanceHdr inst)
+ $$ text "To avoid this"
+ $$ nest 4 (vcat possibilities)
+ where
+ possibilities =
+ text "move the instance declaration to the module of the class or of the type, or" :
+ text "wrap the type with a newtype and declare the instance on the new type." :
+ []
+
+tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
+ -- Add new locally-defined instances
+tcExtendLocalInstEnv dfuns thing_inside
+ = do { traceDFuns dfuns
+ ; env <- getGblEnv
+ ; (inst_env', cls_insts') <- foldlM addLocalInst
+ (tcg_inst_env env, tcg_insts env)
+ dfuns
+ ; let env' = env { tcg_insts = cls_insts'
+ , tcg_inst_env = inst_env' }
+ ; setGblEnv env' thing_inside }
+
+addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])
+-- Check that the proposed new instance is OK,
+-- and then add it to the home inst env
+-- If overwrite_inst, then we can overwrite a direct match
+addLocalInst (home_ie, my_insts) ispec
+ = do {
+ -- Load imported instances, so that we report
+ -- duplicates correctly
+
+ -- 'matches' are existing instance declarations that are less
+ -- specific than the new one
+ -- 'dups' are those 'matches' that are equal to the new one
+ ; isGHCi <- getIsGHCi
+ ; eps <- getEps
+ ; tcg_env <- getGblEnv
+
+ -- In GHCi, we *override* any identical instances
+ -- that are also defined in the interactive context
+ -- See Note [Override identical instances in GHCi]
+ ; let home_ie'
+ | isGHCi = deleteFromInstEnv home_ie ispec
+ | otherwise = home_ie
+
+ global_ie = eps_inst_env eps
+ inst_envs = InstEnvs { ie_global = global_ie
+ , ie_local = home_ie'
+ , ie_visible = tcVisibleOrphanMods tcg_env }
+
+ -- Check for inconsistent functional dependencies
+ ; let inconsistent_ispecs = checkFunDeps inst_envs ispec
+ ; unless (null inconsistent_ispecs) $
+ funDepErr ispec inconsistent_ispecs
+
+ -- Check for duplicate instance decls.
+ ; let (_tvs, cls, tys) = instanceHead ispec
+ (matches, _, _) = lookupInstEnv False inst_envs cls tys
+ dups = filter (identicalClsInstHead ispec) (map fst matches)
+ ; unless (null dups) $
+ dupInstErr ispec (head dups)
+
+ ; return (extendInstEnv home_ie' ispec, ispec : my_insts) }
+
+{-
+Note [Signature files and type class instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Instances in signature files do not have an effect when compiling:
+when you compile a signature against an implementation, you will
+see the instances WHETHER OR NOT the instance is declared in
+the file (this is because the signatures go in the EPS and we
+can't filter them out easily.) This is also why we cannot
+place the instance in the hi file: it would show up as a duplicate,
+and we don't have instance reexports anyway.
+
+However, you might find them useful when typechecking against
+a signature: the instance is a way of indicating to GHC that
+some instance exists, in case downstream code uses it.
+
+Implementing this is a little tricky. Consider the following
+situation (sigof03):
+
+ module A where
+ instance C T where ...
+
+ module ASig where
+ instance C T
+
+When compiling ASig, A.hi is loaded, which brings its instances
+into the EPS. When we process the instance declaration in ASig,
+we should ignore it for the purpose of doing a duplicate check,
+since it's not actually a duplicate. But don't skip the check
+entirely, we still want this to fail (tcfail221):
+
+ module ASig where
+ instance C T
+ instance C T
+
+Note that in some situations, the interface containing the type
+class instances may not have been loaded yet at all. The usual
+situation when A imports another module which provides the
+instances (sigof02m):
+
+ module A(module B) where
+ import B
+
+See also Note [Signature lazy interface loading]. We can't
+rely on this, however, since sometimes we'll have spurious
+type class instances in the EPS, see #9422 (sigof02dm)
+
+************************************************************************
+* *
+ Errors and tracing
+* *
+************************************************************************
+-}
+
+traceDFuns :: [ClsInst] -> TcRn ()
+traceDFuns ispecs
+ = traceTc "Adding instances:" (vcat (map pp ispecs))
+ where
+ pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)
+ 2 (ppr ispec)
+ -- Print the dfun name itself too
+
+funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
+funDepErr ispec ispecs
+ = addClsInstsErr (text "Functional dependencies conflict between instance declarations:")
+ (ispec : ispecs)
+
+dupInstErr :: ClsInst -> ClsInst -> TcRn ()
+dupInstErr ispec dup_ispec
+ = addClsInstsErr (text "Duplicate instance declarations:")
+ [ispec, dup_ispec]
+
+addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
+addClsInstsErr herald ispecs
+ = setSrcSpan (getSrcSpan (head sorted)) $
+ addErr (hang herald 2 (pprInstances sorted))
+ where
+ sorted = sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs
+ -- The sortBy just arranges that instances are displayed in order
+ -- of source location, which reduced wobbling in error messages,
+ -- and is better for users
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
new file mode 100644
index 0000000000..bd52015c89
--- /dev/null
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -0,0 +1,1998 @@
+{-
+(c) The University of Glasgow 2006
+
+-}
+
+{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances, BangPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+{-# LANGUAGE ViewPatterns #-}
+
+
+-- | Functions for working with the typechecker environment (setters,
+-- getters...).
+module GHC.Tc.Utils.Monad(
+ -- * Initialisation
+ initTc, initTcWithGbl, initTcInteractive, initTcRnIf,
+
+ -- * Simple accessors
+ discardResult,
+ getTopEnv, updTopEnv, getGblEnv, updGblEnv,
+ setGblEnv, getLclEnv, updLclEnv, setLclEnv,
+ getEnvs, setEnvs,
+ xoptM, doptM, goptM, woptM,
+ setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,
+ whenDOptM, whenGOptM, whenWOptM,
+ whenXOptM, unlessXOptM,
+ getGhcMode,
+ withDoDynamicToo,
+ getEpsVar,
+ getEps,
+ updateEps, updateEps_,
+ getHpt, getEpsAndHpt,
+
+ -- * Arrow scopes
+ newArrowScope, escapeArrowScope,
+
+ -- * Unique supply
+ newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName,
+ newSysName, newSysLocalId, newSysLocalIds,
+
+ -- * Accessing input/output
+ newTcRef, readTcRef, writeTcRef, updTcRef,
+
+ -- * Debugging
+ traceTc, traceRn, traceOptTcRn, dumpOptTcRn,
+ dumpTcRn,
+ getPrintUnqualified,
+ printForUserTcRn,
+ traceIf, traceHiDiffs, traceOptIf,
+ debugTc,
+
+ -- * Typechecker global environment
+ getIsGHCi, getGHCiMonad, getInteractivePrintName,
+ tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv,
+ getRdrEnvs, getImports,
+ getFixityEnv, extendFixityEnv, getRecFieldEnv,
+ getDeclaredDefaultTys,
+ addDependentFiles,
+
+ -- * Error management
+ getSrcSpanM, setSrcSpan, addLocM,
+ wrapLocM, wrapLocFstM, wrapLocSndM,wrapLocM_,
+ getErrsVar, setErrsVar,
+ addErr,
+ failWith, failAt,
+ addErrAt, addErrs,
+ checkErr,
+ addMessages,
+ discardWarnings,
+
+ -- * Shared error message stuff: renamer and typechecker
+ mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,
+ reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,
+ attemptM, tryTc,
+ askNoErrs, discardErrs, tryTcDiscardingErrs,
+ checkNoErrs, whenNoErrs,
+ ifErrsM, failIfErrsM,
+
+ -- * Context management for the type checker
+ getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,
+ addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM,
+
+ -- * Error message generation (type checker)
+ addErrTc, addErrsTc,
+ addErrTcM, mkErrTcM, mkErrTc,
+ failWithTc, failWithTcM,
+ checkTc, checkTcM,
+ failIfTc, failIfTcM,
+ warnIfFlag, warnIf, warnTc, warnTcM,
+ addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn,
+ mkErrInfo,
+
+ -- * Type constraints
+ newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar,
+ addTcEvBind, addTopEvBinds,
+ getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
+ chooseUniqueOccTc,
+ getConstraintVar, setConstraintVar,
+ emitConstraints, emitStaticConstraints, emitSimple, emitSimples,
+ emitImplication, emitImplications, emitInsoluble,
+ discardConstraints, captureConstraints, tryCaptureConstraints,
+ pushLevelAndCaptureConstraints,
+ pushTcLevelM_, pushTcLevelM, pushTcLevelsM,
+ getTcLevel, setTcLevel, isTouchableTcM,
+ getLclTypeEnv, setLclTypeEnv,
+ traceTcConstraints,
+ emitNamedWildCardHoleConstraints, emitAnonWildCardHoleConstraint,
+
+ -- * Template Haskell context
+ recordThUse, recordThSpliceUse,
+ keepAlive, getStage, getStageAndBindLevel, setStage,
+ addModFinalizersWithLclEnv,
+
+ -- * Safe Haskell context
+ recordUnsafeInfer, finalSafeMode, fixSafeInstances,
+
+ -- * Stuff for the renamer's local env
+ getLocalRdrEnv, setLocalRdrEnv,
+
+ -- * Stuff for interface decls
+ mkIfLclEnv,
+ initIfaceTcRn,
+ initIfaceCheck,
+ initIfaceLcl,
+ initIfaceLclWithSubst,
+ initIfaceLoad,
+ getIfModule,
+ failIfM,
+ forkM_maybe,
+ forkM,
+ setImplicitEnvM,
+
+ withException,
+
+ -- * Stuff for cost centres.
+ ContainsCostCentreState(..), getCCIndexM,
+
+ -- * Types etc.
+ module GHC.Tc.Types,
+ module IOEnv
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHC.Tc.Types -- Re-export all
+import IOEnv -- Re-export all
+import GHC.Tc.Types.Constraint
+import GHC.Tc.Types.Evidence
+import GHC.Tc.Types.Origin
+
+import GHC.Hs hiding (LIE)
+import GHC.Driver.Types
+import GHC.Types.Module
+import GHC.Types.Name.Reader
+import GHC.Types.Name
+import GHC.Core.Type
+
+import GHC.Tc.Utils.TcType
+import GHC.Core.InstEnv
+import GHC.Core.FamInstEnv
+import PrelNames
+
+import GHC.Types.Id
+import GHC.Types.Var.Set
+import GHC.Types.Var.Env
+import ErrUtils
+import GHC.Types.SrcLoc
+import GHC.Types.Name.Env
+import GHC.Types.Name.Set
+import Bag
+import Outputable
+import GHC.Types.Unique.Supply
+import GHC.Driver.Session
+import FastString
+import Panic
+import Util
+import GHC.Types.Annotations
+import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) )
+import Maybes
+import GHC.Types.CostCentre.State
+
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.IORef
+import Control.Monad
+
+import {-# SOURCE #-} GHC.Tc.Utils.Env ( tcInitTidyEnv )
+
+import qualified Data.Map as Map
+
+{-
+************************************************************************
+* *
+ initTc
+* *
+************************************************************************
+-}
+
+-- | Setup the initial typechecking environment
+initTc :: HscEnv
+ -> HscSource
+ -> Bool -- True <=> retain renamed syntax trees
+ -> Module
+ -> RealSrcSpan
+ -> TcM r
+ -> IO (Messages, Maybe r)
+ -- Nothing => error thrown by the thing inside
+ -- (error messages should have been printed already)
+
+initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
+ = do { keep_var <- newIORef emptyNameSet ;
+ used_gre_var <- newIORef [] ;
+ th_var <- newIORef False ;
+ th_splice_var<- newIORef False ;
+ infer_var <- newIORef (True, emptyBag) ;
+ dfun_n_var <- newIORef emptyOccSet ;
+ type_env_var <- case hsc_type_env_var hsc_env of {
+ Just (_mod, te_var) -> return te_var ;
+ Nothing -> newIORef emptyNameEnv } ;
+
+ dependent_files_var <- newIORef [] ;
+ static_wc_var <- newIORef emptyWC ;
+ cc_st_var <- newIORef newCostCentreState ;
+ th_topdecls_var <- newIORef [] ;
+ th_foreign_files_var <- newIORef [] ;
+ th_topnames_var <- newIORef emptyNameSet ;
+ th_modfinalizers_var <- newIORef [] ;
+ th_coreplugins_var <- newIORef [] ;
+ th_state_var <- newIORef Map.empty ;
+ th_remote_state_var <- newIORef Nothing ;
+ let {
+ dflags = hsc_dflags hsc_env ;
+
+ maybe_rn_syntax :: forall a. a -> Maybe a ;
+ maybe_rn_syntax empty_val
+ | dopt Opt_D_dump_rn_ast dflags = Just empty_val
+
+ | gopt Opt_WriteHie dflags = Just empty_val
+
+ -- We want to serialize the documentation in the .hi-files,
+ -- and need to extract it from the renamed syntax first.
+ -- See 'GHC.HsToCore.Docs.extractDocs'.
+ | gopt Opt_Haddock dflags = Just empty_val
+
+ | keep_rn_syntax = Just empty_val
+ | otherwise = Nothing ;
+
+ gbl_env = TcGblEnv {
+ tcg_th_topdecls = th_topdecls_var,
+ tcg_th_foreign_files = th_foreign_files_var,
+ tcg_th_topnames = th_topnames_var,
+ tcg_th_modfinalizers = th_modfinalizers_var,
+ tcg_th_coreplugins = th_coreplugins_var,
+ tcg_th_state = th_state_var,
+ tcg_th_remote_state = th_remote_state_var,
+
+ tcg_mod = mod,
+ tcg_semantic_mod =
+ canonicalizeModuleIfHome dflags mod,
+ tcg_src = hsc_src,
+ tcg_rdr_env = emptyGlobalRdrEnv,
+ tcg_fix_env = emptyNameEnv,
+ tcg_field_env = emptyNameEnv,
+ tcg_default = if moduleUnitId mod == primUnitId
+ then Just [] -- See Note [Default types]
+ else Nothing,
+ tcg_type_env = emptyNameEnv,
+ tcg_type_env_var = type_env_var,
+ tcg_inst_env = emptyInstEnv,
+ tcg_fam_inst_env = emptyFamInstEnv,
+ tcg_ann_env = emptyAnnEnv,
+ tcg_th_used = th_var,
+ tcg_th_splice_used = th_splice_var,
+ tcg_exports = [],
+ tcg_imports = emptyImportAvails,
+ tcg_used_gres = used_gre_var,
+ tcg_dus = emptyDUs,
+
+ tcg_rn_imports = [],
+ tcg_rn_exports =
+ if hsc_src == HsigFile
+ -- Always retain renamed syntax, so that we can give
+ -- better errors. (TODO: how?)
+ then Just []
+ else maybe_rn_syntax [],
+ tcg_rn_decls = maybe_rn_syntax emptyRnGroup,
+ tcg_tr_module = Nothing,
+ tcg_binds = emptyLHsBinds,
+ tcg_imp_specs = [],
+ tcg_sigs = emptyNameSet,
+ tcg_ev_binds = emptyBag,
+ tcg_warns = NoWarnings,
+ tcg_anns = [],
+ tcg_tcs = [],
+ tcg_insts = [],
+ tcg_fam_insts = [],
+ tcg_rules = [],
+ tcg_fords = [],
+ tcg_patsyns = [],
+ tcg_merged = [],
+ tcg_dfun_n = dfun_n_var,
+ tcg_keep = keep_var,
+ tcg_doc_hdr = Nothing,
+ tcg_hpc = False,
+ tcg_main = Nothing,
+ tcg_self_boot = NoSelfBoot,
+ tcg_safeInfer = infer_var,
+ tcg_dependent_files = dependent_files_var,
+ tcg_tc_plugins = [],
+ tcg_hf_plugins = [],
+ tcg_top_loc = loc,
+ tcg_static_wc = static_wc_var,
+ tcg_complete_matches = [],
+ tcg_cc_st = cc_st_var
+ } ;
+ } ;
+
+ -- OK, here's the business end!
+ initTcWithGbl hsc_env gbl_env loc do_this
+ }
+
+-- | Run a 'TcM' action in the context of an existing 'GblEnv'.
+initTcWithGbl :: HscEnv
+ -> TcGblEnv
+ -> RealSrcSpan
+ -> TcM r
+ -> IO (Messages, Maybe r)
+initTcWithGbl hsc_env gbl_env loc do_this
+ = do { lie_var <- newIORef emptyWC
+ ; errs_var <- newIORef (emptyBag, emptyBag)
+ ; let lcl_env = TcLclEnv {
+ tcl_errs = errs_var,
+ tcl_loc = loc, -- Should be over-ridden very soon!
+ tcl_ctxt = [],
+ tcl_rdr = emptyLocalRdrEnv,
+ tcl_th_ctxt = topStage,
+ tcl_th_bndrs = emptyNameEnv,
+ tcl_arrow_ctxt = NoArrowCtxt,
+ tcl_env = emptyNameEnv,
+ tcl_bndrs = [],
+ tcl_lie = lie_var,
+ tcl_tclvl = topTcLevel
+ }
+
+ ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
+ do { r <- tryM do_this
+ ; case r of
+ Right res -> return (Just res)
+ Left _ -> return Nothing }
+
+ -- Check for unsolved constraints
+ -- If we succeed (maybe_res = Just r), there should be
+ -- no unsolved constraints. But if we exit via an
+ -- exception (maybe_res = Nothing), we may have skipped
+ -- solving, so don't panic then (#13466)
+ ; lie <- readIORef (tcl_lie lcl_env)
+ ; when (isJust maybe_res && not (isEmptyWC lie)) $
+ pprPanic "initTc: unsolved constraints" (ppr lie)
+
+ -- Collect any error messages
+ ; msgs <- readIORef (tcl_errs lcl_env)
+
+ ; let { final_res | errorsFound dflags msgs = Nothing
+ | otherwise = maybe_res }
+
+ ; return (msgs, final_res)
+ }
+ where dflags = hsc_dflags hsc_env
+
+initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)
+-- Initialise the type checker monad for use in GHCi
+initTcInteractive hsc_env thing_inside
+ = initTc hsc_env HsSrcFile False
+ (icInteractiveModule (hsc_IC hsc_env))
+ (realSrcLocSpan interactive_src_loc)
+ thing_inside
+ where
+ interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
+
+{- Note [Default types]
+~~~~~~~~~~~~~~~~~~~~~~~
+The Integer type is simply not available in package ghc-prim (it is
+declared in integer-gmp). So we set the defaulting types to (Just
+[]), meaning there are no default types, rather then Nothing, which
+means "use the default default types of Integer, Double".
+
+If you don't do this, attempted defaulting in package ghc-prim causes
+an actual crash (attempting to look up the Integer type).
+
+
+************************************************************************
+* *
+ Initialisation
+* *
+************************************************************************
+-}
+
+initTcRnIf :: Char -- ^ Mask for unique supply
+ -> HscEnv
+ -> gbl -> lcl
+ -> TcRnIf gbl lcl a
+ -> IO a
+initTcRnIf uniq_mask hsc_env gbl_env lcl_env thing_inside
+ = do { let { env = Env { env_top = hsc_env,
+ env_um = uniq_mask,
+ env_gbl = gbl_env,
+ env_lcl = lcl_env} }
+
+ ; runIOEnv env thing_inside
+ }
+
+{-
+************************************************************************
+* *
+ Simple accessors
+* *
+************************************************************************
+-}
+
+discardResult :: TcM a -> TcM ()
+discardResult a = a >> return ()
+
+getTopEnv :: TcRnIf gbl lcl HscEnv
+getTopEnv = do { env <- getEnv; return (env_top env) }
+
+updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+updTopEnv upd = updEnv (\ env@(Env { env_top = top }) ->
+ env { env_top = upd top })
+
+getGblEnv :: TcRnIf gbl lcl gbl
+getGblEnv = do { Env{..} <- getEnv; return env_gbl }
+
+updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
+ env { env_gbl = upd gbl })
+
+setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
+
+getLclEnv :: TcRnIf gbl lcl lcl
+getLclEnv = do { Env{..} <- getEnv; return env_lcl }
+
+updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
+ env { env_lcl = upd lcl })
+
+setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
+setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
+
+getEnvs :: TcRnIf gbl lcl (gbl, lcl)
+getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
+
+setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
+setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
+
+-- Command-line flags
+
+xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool
+xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) }
+
+doptM :: DumpFlag -> TcRnIf gbl lcl Bool
+doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) }
+
+goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
+goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) }
+
+woptM :: WarningFlag -> TcRnIf gbl lcl Bool
+woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) }
+
+setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+setXOptM flag =
+ updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag})
+
+unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+unsetXOptM flag =
+ updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag})
+
+unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+unsetGOptM flag =
+ updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag})
+
+unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+unsetWOptM flag =
+ updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag})
+
+-- | Do it flag is true
+whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+whenDOptM flag thing_inside = do b <- doptM flag
+ when b thing_inside
+
+whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+whenGOptM flag thing_inside = do b <- goptM flag
+ when b thing_inside
+
+whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+whenWOptM flag thing_inside = do b <- woptM flag
+ when b thing_inside
+
+whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+whenXOptM flag thing_inside = do b <- xoptM flag
+ when b thing_inside
+
+unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+unlessXOptM flag thing_inside = do b <- xoptM flag
+ unless b thing_inside
+
+getGhcMode :: TcRnIf gbl lcl GhcMode
+getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
+
+withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+withDoDynamicToo =
+ updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->
+ top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags })
+
+getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
+getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
+
+getEps :: TcRnIf gbl lcl ExternalPackageState
+getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
+
+-- | Update the external package state. Returns the second result of the
+-- modifier function.
+--
+-- This is an atomic operation and forces evaluation of the modified EPS in
+-- order to avoid space leaks.
+updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
+ -> TcRnIf gbl lcl a
+updateEps upd_fn = do
+ traceIf (text "updating EPS")
+ eps_var <- getEpsVar
+ atomicUpdMutVar' eps_var upd_fn
+
+-- | Update the external package state.
+--
+-- This is an atomic operation and forces evaluation of the modified EPS in
+-- order to avoid space leaks.
+updateEps_ :: (ExternalPackageState -> ExternalPackageState)
+ -> TcRnIf gbl lcl ()
+updateEps_ upd_fn = do
+ traceIf (text "updating EPS_")
+ eps_var <- getEpsVar
+ atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
+
+getHpt :: TcRnIf gbl lcl HomePackageTable
+getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
+
+getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
+getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
+ ; return (eps, hsc_HPT env) }
+
+-- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing
+-- an exception if it is an error.
+withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a
+withException do_this = do
+ r <- do_this
+ dflags <- getDynFlags
+ case r of
+ Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err))
+ Succeeded result -> return result
+
+{-
+************************************************************************
+* *
+ Arrow scopes
+* *
+************************************************************************
+-}
+
+newArrowScope :: TcM a -> TcM a
+newArrowScope
+ = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }
+
+-- Return to the stored environment (from the enclosing proc)
+escapeArrowScope :: TcM a -> TcM a
+escapeArrowScope
+ = updLclEnv $ \ env ->
+ case tcl_arrow_ctxt env of
+ NoArrowCtxt -> env
+ ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt
+ , tcl_lie = lie
+ , tcl_rdr = rdr_env }
+
+{-
+************************************************************************
+* *
+ Unique supply
+* *
+************************************************************************
+-}
+
+newUnique :: TcRnIf gbl lcl Unique
+newUnique
+ = do { env <- getEnv
+ ; let mask = env_um env
+ ; liftIO $! uniqFromMask mask }
+
+newUniqueSupply :: TcRnIf gbl lcl UniqSupply
+newUniqueSupply
+ = do { env <- getEnv
+ ; let mask = env_um env
+ ; liftIO $! mkSplitUniqSupply mask }
+
+cloneLocalName :: Name -> TcM Name
+-- Make a fresh Internal name with the same OccName and SrcSpan
+cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name)
+
+newName :: OccName -> TcM Name
+newName occ = do { loc <- getSrcSpanM
+ ; newNameAt occ loc }
+
+newNameAt :: OccName -> SrcSpan -> TcM Name
+newNameAt occ span
+ = do { uniq <- newUnique
+ ; return (mkInternalName uniq occ span) }
+
+newSysName :: OccName -> TcRnIf gbl lcl Name
+newSysName occ
+ = do { uniq <- newUnique
+ ; return (mkSystemName uniq occ) }
+
+newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId
+newSysLocalId fs ty
+ = do { u <- newUnique
+ ; return (mkSysLocal fs u ty) }
+
+newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
+newSysLocalIds fs tys
+ = do { us <- newUniqueSupply
+ ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }
+
+instance MonadUnique (IOEnv (Env gbl lcl)) where
+ getUniqueM = newUnique
+ getUniqueSupplyM = newUniqueSupply
+
+{-
+************************************************************************
+* *
+ Accessing input/output
+* *
+************************************************************************
+-}
+
+newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
+newTcRef = newMutVar
+
+readTcRef :: TcRef a -> TcRnIf gbl lcl a
+readTcRef = readMutVar
+
+writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
+writeTcRef = writeMutVar
+
+updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
+-- Returns ()
+updTcRef ref fn = liftIO $ do { old <- readIORef ref
+ ; writeIORef ref (fn old) }
+
+{-
+************************************************************************
+* *
+ Debugging
+* *
+************************************************************************
+-}
+
+
+-- Typechecker trace
+traceTc :: String -> SDoc -> TcRn ()
+traceTc =
+ labelledTraceOptTcRn Opt_D_dump_tc_trace
+
+-- Renamer Trace
+traceRn :: String -> SDoc -> TcRn ()
+traceRn =
+ labelledTraceOptTcRn Opt_D_dump_rn_trace
+
+-- | Trace when a certain flag is enabled. This is like `traceOptTcRn`
+-- but accepts a string as a label and formats the trace message uniformly.
+labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn ()
+labelledTraceOptTcRn flag herald doc = do
+ traceOptTcRn flag (formatTraceMsg herald doc)
+
+formatTraceMsg :: String -> SDoc -> SDoc
+formatTraceMsg herald doc = hang (text herald) 2 doc
+
+-- | Trace if the given 'DumpFlag' is set.
+traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
+traceOptTcRn flag doc = do
+ dflags <- getDynFlags
+ when (dopt flag dflags) $
+ dumpTcRn False (dumpOptionsFromFlag flag) "" FormatText doc
+
+-- | Dump if the given 'DumpFlag' is set.
+dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn ()
+dumpOptTcRn flag title fmt doc = do
+ dflags <- getDynFlags
+ when (dopt flag dflags) $
+ dumpTcRn False (dumpOptionsFromFlag flag) title fmt doc
+
+-- | Unconditionally dump some trace output
+--
+-- Certain tests (T3017, Roles3, T12763 etc.) expect part of the
+-- output generated by `-ddump-types` to be in 'PprUser' style. However,
+-- generally we want all other debugging output to use 'PprDump'
+-- style. We 'PprUser' style if 'useUserStyle' is True.
+--
+dumpTcRn :: Bool -> DumpOptions -> String -> DumpFormat -> SDoc -> TcRn ()
+dumpTcRn useUserStyle dumpOpt title fmt doc = do
+ dflags <- getDynFlags
+ printer <- getPrintUnqualified dflags
+ real_doc <- wrapDocLoc doc
+ let sty = if useUserStyle
+ then mkUserStyle dflags printer AllTheWay
+ else mkDumpStyle dflags printer
+ liftIO $ dumpAction dflags sty dumpOpt title fmt real_doc
+
+-- | Add current location if -dppr-debug
+-- (otherwise the full location is usually way too much)
+wrapDocLoc :: SDoc -> TcRn SDoc
+wrapDocLoc doc = do
+ dflags <- getDynFlags
+ if hasPprDebug dflags
+ then do
+ loc <- getSrcSpanM
+ return (mkLocMessage SevOutput loc doc)
+ else
+ return doc
+
+getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified
+getPrintUnqualified dflags
+ = do { rdr_env <- getGlobalRdrEnv
+ ; return $ mkPrintUnqualified dflags rdr_env }
+
+-- | Like logInfoTcRn, but for user consumption
+printForUserTcRn :: SDoc -> TcRn ()
+printForUserTcRn doc
+ = do { dflags <- getDynFlags
+ ; printer <- getPrintUnqualified dflags
+ ; liftIO (printOutputForUser dflags printer doc) }
+
+{-
+traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is
+available. Alas, they behave inconsistently with the other stuff;
+e.g. are unaffected by -dump-to-file.
+-}
+
+traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
+traceIf = traceOptIf Opt_D_dump_if_trace
+traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
+
+
+traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
+traceOptIf flag doc
+ = whenDOptM flag $ -- No RdrEnv available, so qualify everything
+ do { dflags <- getDynFlags
+ ; liftIO (putMsg dflags doc) }
+
+{-
+************************************************************************
+* *
+ Typechecker global environment
+* *
+************************************************************************
+-}
+
+getIsGHCi :: TcRn Bool
+getIsGHCi = do { mod <- getModule
+ ; return (isInteractiveModule mod) }
+
+getGHCiMonad :: TcRn Name
+getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }
+
+getInteractivePrintName :: TcRn Name
+getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }
+
+tcIsHsBootOrSig :: TcRn Bool
+tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }
+
+tcIsHsig :: TcRn Bool
+tcIsHsig = do { env <- getGblEnv; return (isHsigFile (tcg_src env)) }
+
+tcSelfBootInfo :: TcRn SelfBootInfo
+tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) }
+
+getGlobalRdrEnv :: TcRn GlobalRdrEnv
+getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
+
+getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
+getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }
+
+getImports :: TcRn ImportAvails
+getImports = do { env <- getGblEnv; return (tcg_imports env) }
+
+getFixityEnv :: TcRn FixityEnv
+getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
+
+extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
+extendFixityEnv new_bit
+ = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
+ env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
+
+getRecFieldEnv :: TcRn RecFieldEnv
+getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
+
+getDeclaredDefaultTys :: TcRn (Maybe [Type])
+getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
+
+addDependentFiles :: [FilePath] -> TcRn ()
+addDependentFiles fs = do
+ ref <- fmap tcg_dependent_files getGblEnv
+ dep_files <- readTcRef ref
+ writeTcRef ref (fs ++ dep_files)
+
+{-
+************************************************************************
+* *
+ Error management
+* *
+************************************************************************
+-}
+
+getSrcSpanM :: TcRn SrcSpan
+ -- Avoid clash with Name.getSrcLoc
+getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) }
+
+setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
+setSrcSpan (RealSrcSpan real_loc _) thing_inside
+ = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside
+-- Don't overwrite useful info with useless:
+setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
+
+addLocM :: (a -> TcM b) -> Located a -> TcM b
+addLocM fn (L loc a) = setSrcSpan loc $ fn a
+
+wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
+-- wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
+wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a
+ ; return (L loc b) }
+
+wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
+wrapLocFstM fn (L loc a) =
+ setSrcSpan loc $ do
+ (b,c) <- fn a
+ return (L loc b, c)
+
+wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c)
+wrapLocSndM fn (L loc a) =
+ setSrcSpan loc $ do
+ (b,c) <- fn a
+ return (b, L loc c)
+
+wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM ()
+wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a)
+
+-- Reporting errors
+
+getErrsVar :: TcRn (TcRef Messages)
+getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
+
+setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
+setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v })
+
+addErr :: MsgDoc -> TcRn ()
+addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
+
+failWith :: MsgDoc -> TcRn a
+failWith msg = addErr msg >> failM
+
+failAt :: SrcSpan -> MsgDoc -> TcRn a
+failAt loc msg = addErrAt loc msg >> failM
+
+addErrAt :: SrcSpan -> MsgDoc -> TcRn ()
+-- addErrAt is mainly (exclusively?) used by the renamer, where
+-- tidying is not an issue, but it's all lazy so the extra
+-- work doesn't matter
+addErrAt loc msg = do { ctxt <- getErrCtxt
+ ; tidy_env <- tcInitTidyEnv
+ ; err_info <- mkErrInfo tidy_env ctxt
+ ; addLongErrAt loc msg err_info }
+
+addErrs :: [(SrcSpan,MsgDoc)] -> TcRn ()
+addErrs msgs = mapM_ add msgs
+ where
+ add (loc,msg) = addErrAt loc msg
+
+checkErr :: Bool -> MsgDoc -> TcRn ()
+-- Add the error if the bool is False
+checkErr ok msg = unless ok (addErr msg)
+
+addMessages :: Messages -> TcRn ()
+addMessages msgs1
+ = do { errs_var <- getErrsVar ;
+ msgs0 <- readTcRef errs_var ;
+ writeTcRef errs_var (unionMessages msgs0 msgs1) }
+
+discardWarnings :: TcRn a -> TcRn a
+-- Ignore warnings inside the thing inside;
+-- used to ignore-unused-variable warnings inside derived code
+discardWarnings thing_inside
+ = do { errs_var <- getErrsVar
+ ; (old_warns, _) <- readTcRef errs_var
+
+ ; result <- thing_inside
+
+ -- Revert warnings to old_warns
+ ; (_new_warns, new_errs) <- readTcRef errs_var
+ ; writeTcRef errs_var (old_warns, new_errs)
+
+ ; return result }
+
+{-
+************************************************************************
+* *
+ Shared error message stuff: renamer and typechecker
+* *
+************************************************************************
+-}
+
+mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
+mkLongErrAt loc msg extra
+ = do { dflags <- getDynFlags ;
+ printer <- getPrintUnqualified dflags ;
+ return $ mkLongErrMsg dflags loc printer msg extra }
+
+mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg
+mkErrDocAt loc errDoc
+ = do { dflags <- getDynFlags ;
+ printer <- getPrintUnqualified dflags ;
+ return $ mkErrDoc dflags loc printer errDoc }
+
+addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
+addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError
+
+reportErrors :: [ErrMsg] -> TcM ()
+reportErrors = mapM_ reportError
+
+reportError :: ErrMsg -> TcRn ()
+reportError err
+ = do { traceTc "Adding error:" (pprLocErrMsg err) ;
+ errs_var <- getErrsVar ;
+ (warns, errs) <- readTcRef errs_var ;
+ writeTcRef errs_var (warns, errs `snocBag` err) }
+
+reportWarning :: WarnReason -> ErrMsg -> TcRn ()
+reportWarning reason err
+ = do { let warn = makeIntoWarning reason err
+ -- 'err' was built by mkLongErrMsg or something like that,
+ -- so it's of error severity. For a warning we downgrade
+ -- its severity to SevWarning
+
+ ; traceTc "Adding warning:" (pprLocErrMsg warn)
+ ; errs_var <- getErrsVar
+ ; (warns, errs) <- readTcRef errs_var
+ ; writeTcRef errs_var (warns `snocBag` warn, errs) }
+
+
+-----------------------
+checkNoErrs :: TcM r -> TcM r
+-- (checkNoErrs m) succeeds iff m succeeds and generates no errors
+-- If m fails then (checkNoErrsTc m) fails.
+-- If m succeeds, it checks whether m generated any errors messages
+-- (it might have recovered internally)
+-- If so, it fails too.
+-- Regardless, any errors generated by m are propagated to the enclosing context.
+checkNoErrs main
+ = do { (res, no_errs) <- askNoErrs main
+ ; unless no_errs failM
+ ; return res }
+
+-----------------------
+whenNoErrs :: TcM () -> TcM ()
+whenNoErrs thing = ifErrsM (return ()) thing
+
+ifErrsM :: TcRn r -> TcRn r -> TcRn r
+-- ifErrsM bale_out normal
+-- does 'bale_out' if there are errors in errors collection
+-- otherwise does 'normal'
+ifErrsM bale_out normal
+ = do { errs_var <- getErrsVar ;
+ msgs <- readTcRef errs_var ;
+ dflags <- getDynFlags ;
+ if errorsFound dflags msgs then
+ bale_out
+ else
+ normal }
+
+failIfErrsM :: TcRn ()
+-- Useful to avoid error cascades
+failIfErrsM = ifErrsM failM (return ())
+
+{- *********************************************************************
+* *
+ Context management for the type checker
+* *
+************************************************************************
+-}
+
+getErrCtxt :: TcM [ErrCtxt]
+getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
+
+setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
+setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
+
+-- | Add a fixed message to the error context. This message should not
+-- do any tidying.
+addErrCtxt :: MsgDoc -> TcM a -> TcM a
+addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
+
+-- | Add a message to the error context. This message may do tidying.
+addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
+addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
+
+-- | Add a fixed landmark message to the error context. A landmark
+-- message is always sure to be reported, even if there is a lot of
+-- context. It also doesn't count toward the maximum number of contexts
+-- reported.
+addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
+addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))
+
+-- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations
+-- and tidying.
+addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
+addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts)
+
+-- Helper function for the above
+updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
+updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
+ env { tcl_ctxt = upd ctxt })
+
+popErrCtxt :: TcM a -> TcM a
+popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
+
+getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
+getCtLocM origin t_or_k
+ = do { env <- getLclEnv
+ ; return (CtLoc { ctl_origin = origin
+ , ctl_env = env
+ , ctl_t_or_k = t_or_k
+ , ctl_depth = initialSubGoalDepth }) }
+
+setCtLocM :: CtLoc -> TcM a -> TcM a
+-- Set the SrcSpan and error context from the CtLoc
+setCtLocM (CtLoc { ctl_env = lcl }) thing_inside
+ = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl
+ , tcl_bndrs = tcl_bndrs lcl
+ , tcl_ctxt = tcl_ctxt lcl })
+ thing_inside
+
+
+{- *********************************************************************
+* *
+ Error recovery and exceptions
+* *
+********************************************************************* -}
+
+tcTryM :: TcRn r -> TcRn (Maybe r)
+-- The most basic function: catch the exception
+-- Nothing => an exception happened
+-- Just r => no exception, result R
+-- Errors and constraints are propagated in both cases
+-- Never throws an exception
+tcTryM thing_inside
+ = do { either_res <- tryM thing_inside
+ ; return (case either_res of
+ Left _ -> Nothing
+ Right r -> Just r) }
+ -- In the Left case the exception is always the IOEnv
+ -- built-in in exception; see IOEnv.failM
+
+-----------------------
+capture_constraints :: TcM r -> TcM (r, WantedConstraints)
+-- capture_constraints simply captures and returns the
+-- constraints generated by thing_inside
+-- Precondition: thing_inside must not throw an exception!
+-- Reason for precondition: an exception would blow past the place
+-- where we read the lie_var, and we'd lose the constraints altogether
+capture_constraints thing_inside
+ = do { lie_var <- newTcRef emptyWC
+ ; res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) $
+ thing_inside
+ ; lie <- readTcRef lie_var
+ ; return (res, lie) }
+
+capture_messages :: TcM r -> TcM (r, Messages)
+-- capture_messages simply captures and returns the
+-- errors arnd warnings generated by thing_inside
+-- Precondition: thing_inside must not throw an exception!
+-- Reason for precondition: an exception would blow past the place
+-- where we read the msg_var, and we'd lose the constraints altogether
+capture_messages thing_inside
+ = do { msg_var <- newTcRef emptyMessages
+ ; res <- setErrsVar msg_var thing_inside
+ ; msgs <- readTcRef msg_var
+ ; return (res, msgs) }
+
+-----------------------
+-- (askNoErrs m) runs m
+-- If m fails,
+-- then (askNoErrs m) fails, propagating only
+-- insoluble constraints
+--
+-- If m succeeds with result r,
+-- then (askNoErrs m) succeeds with result (r, b),
+-- where b is True iff m generated no errors
+--
+-- Regardless of success or failure,
+-- propagate any errors/warnings generated by m
+askNoErrs :: TcRn a -> TcRn (a, Bool)
+askNoErrs thing_inside
+ = do { ((mb_res, lie), msgs) <- capture_messages $
+ capture_constraints $
+ tcTryM thing_inside
+ ; addMessages msgs
+
+ ; case mb_res of
+ Nothing -> do { emitConstraints (insolublesOnly lie)
+ ; failM }
+
+ Just res -> do { emitConstraints lie
+ ; dflags <- getDynFlags
+ ; let errs_found = errorsFound dflags msgs
+ || insolubleWC lie
+ ; return (res, not errs_found) } }
+
+-----------------------
+tryCaptureConstraints :: TcM a -> TcM (Maybe a, WantedConstraints)
+-- (tryCaptureConstraints_maybe m) runs m,
+-- and returns the type constraints it generates
+-- It never throws an exception; instead if thing_inside fails,
+-- it returns Nothing and the /insoluble/ constraints
+-- Error messages are propagated
+tryCaptureConstraints thing_inside
+ = do { (mb_res, lie) <- capture_constraints $
+ tcTryM thing_inside
+
+ -- See Note [Constraints and errors]
+ ; let lie_to_keep = case mb_res of
+ Nothing -> insolublesOnly lie
+ Just {} -> lie
+
+ ; return (mb_res, lie_to_keep) }
+
+captureConstraints :: TcM a -> TcM (a, WantedConstraints)
+-- (captureConstraints m) runs m, and returns the type constraints it generates
+-- If thing_inside fails (throwing an exception),
+-- then (captureConstraints thing_inside) fails too
+-- propagating the insoluble constraints only
+-- Error messages are propagated in either case
+captureConstraints thing_inside
+ = do { (mb_res, lie) <- tryCaptureConstraints thing_inside
+
+ -- See Note [Constraints and errors]
+ -- If the thing_inside threw an exception, emit the insoluble
+ -- constraints only (returned by tryCaptureConstraints)
+ -- so that they are not lost
+ ; case mb_res of
+ Nothing -> do { emitConstraints lie; failM }
+ Just res -> return (res, lie) }
+
+-----------------------
+attemptM :: TcRn r -> TcRn (Maybe r)
+-- (attemptM thing_inside) runs thing_inside
+-- If thing_inside succeeds, returning r,
+-- we return (Just r), and propagate all constraints and errors
+-- If thing_inside fail, throwing an exception,
+-- we return Nothing, propagating insoluble constraints,
+-- and all errors
+-- attemptM never throws an exception
+attemptM thing_inside
+ = do { (mb_r, lie) <- tryCaptureConstraints thing_inside
+ ; emitConstraints lie
+
+ -- Debug trace
+ ; when (isNothing mb_r) $
+ traceTc "attemptM recovering with insoluble constraints" $
+ (ppr lie)
+
+ ; return mb_r }
+
+-----------------------
+recoverM :: TcRn r -- Recovery action; do this if the main one fails
+ -> TcRn r -- Main action: do this first;
+ -- if it generates errors, propagate them all
+ -> TcRn r
+-- (recoverM recover thing_inside) runs thing_inside
+-- If thing_inside fails, propagate its errors and insoluble constraints
+-- and run 'recover'
+-- If thing_inside succeeds, propagate all its errors and constraints
+--
+-- Can fail, if 'recover' fails
+recoverM recover thing
+ = do { mb_res <- attemptM thing ;
+ case mb_res of
+ Nothing -> recover
+ Just res -> return res }
+
+-----------------------
+
+-- | Drop elements of the input that fail, so the result
+-- list can be shorter than the argument list
+mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
+mapAndRecoverM f xs
+ = do { mb_rs <- mapM (attemptM . f) xs
+ ; return [r | Just r <- mb_rs] }
+
+-- | Apply the function to all elements on the input list
+-- If all succeed, return the list of results
+-- Otherwise fail, propagating all errors
+mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
+mapAndReportM f xs
+ = do { mb_rs <- mapM (attemptM . f) xs
+ ; when (any isNothing mb_rs) failM
+ ; return [r | Just r <- mb_rs] }
+
+-- | The accumulator is not updated if the action fails
+foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b
+foldAndRecoverM _ acc [] = return acc
+foldAndRecoverM f acc (x:xs) =
+ do { mb_r <- attemptM (f acc x)
+ ; case mb_r of
+ Nothing -> foldAndRecoverM f acc xs
+ Just acc' -> foldAndRecoverM f acc' xs }
+
+-----------------------
+tryTc :: TcRn a -> TcRn (Maybe a, Messages)
+-- (tryTc m) executes m, and returns
+-- Just r, if m succeeds (returning r)
+-- Nothing, if m fails
+-- It also returns all the errors and warnings accumulated by m
+-- It always succeeds (never raises an exception)
+tryTc thing_inside
+ = capture_messages (attemptM thing_inside)
+
+-----------------------
+discardErrs :: TcRn a -> TcRn a
+-- (discardErrs m) runs m,
+-- discarding all error messages and warnings generated by m
+-- If m fails, discardErrs fails, and vice versa
+discardErrs m
+ = do { errs_var <- newTcRef emptyMessages
+ ; setErrsVar errs_var m }
+
+-----------------------
+tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r
+-- (tryTcDiscardingErrs recover thing_inside) tries 'thing_inside';
+-- if 'main' succeeds with no error messages, it's the answer
+-- otherwise discard everything from 'main', including errors,
+-- and try 'recover' instead.
+tryTcDiscardingErrs recover thing_inside
+ = do { ((mb_res, lie), msgs) <- capture_messages $
+ capture_constraints $
+ tcTryM thing_inside
+ ; dflags <- getDynFlags
+ ; case mb_res of
+ Just res | not (errorsFound dflags msgs)
+ , not (insolubleWC lie)
+ -> -- 'main' succeeded with no errors
+ do { addMessages msgs -- msgs might still have warnings
+ ; emitConstraints lie
+ ; return res }
+
+ _ -> -- 'main' failed, or produced an error message
+ recover -- Discard all errors and warnings
+ -- and unsolved constraints entirely
+ }
+
+{-
+************************************************************************
+* *
+ Error message generation (type checker)
+* *
+************************************************************************
+
+ The addErrTc functions add an error message, but do not cause failure.
+ The 'M' variants pass a TidyEnv that has already been used to
+ tidy up the message; we then use it to tidy the context messages
+-}
+
+addErrTc :: MsgDoc -> TcM ()
+addErrTc err_msg = do { env0 <- tcInitTidyEnv
+ ; addErrTcM (env0, err_msg) }
+
+addErrsTc :: [MsgDoc] -> TcM ()
+addErrsTc err_msgs = mapM_ addErrTc err_msgs
+
+addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()
+addErrTcM (tidy_env, err_msg)
+ = do { ctxt <- getErrCtxt ;
+ loc <- getSrcSpanM ;
+ add_err_tcm tidy_env err_msg loc ctxt }
+
+-- Return the error message, instead of reporting it straight away
+mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg
+mkErrTcM (tidy_env, err_msg)
+ = do { ctxt <- getErrCtxt ;
+ loc <- getSrcSpanM ;
+ err_info <- mkErrInfo tidy_env ctxt ;
+ mkLongErrAt loc err_msg err_info }
+
+mkErrTc :: MsgDoc -> TcM ErrMsg
+mkErrTc msg = do { env0 <- tcInitTidyEnv
+ ; mkErrTcM (env0, msg) }
+
+-- The failWith functions add an error message and cause failure
+
+failWithTc :: MsgDoc -> TcM a -- Add an error message and fail
+failWithTc err_msg
+ = addErrTc err_msg >> failM
+
+failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail
+failWithTcM local_and_msg
+ = addErrTcM local_and_msg >> failM
+
+checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true
+checkTc True _ = return ()
+checkTc False err = failWithTc err
+
+checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
+checkTcM True _ = return ()
+checkTcM False err = failWithTcM err
+
+failIfTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is false
+failIfTc False _ = return ()
+failIfTc True err = failWithTc err
+
+failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
+ -- Check that the boolean is false
+failIfTcM False _ = return ()
+failIfTcM True err = failWithTcM err
+
+
+-- Warnings have no 'M' variant, nor failure
+
+-- | Display a warning if a condition is met,
+-- and the warning is enabled
+warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn ()
+warnIfFlag warn_flag is_bad msg
+ = do { warn_on <- woptM warn_flag
+ ; when (warn_on && is_bad) $
+ addWarn (Reason warn_flag) msg }
+
+-- | Display a warning if a condition is met.
+warnIf :: Bool -> MsgDoc -> TcRn ()
+warnIf is_bad msg
+ = when is_bad (addWarn NoReason msg)
+
+-- | Display a warning if a condition is met.
+warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()
+warnTc reason warn_if_true warn_msg
+ | warn_if_true = addWarnTc reason warn_msg
+ | otherwise = return ()
+
+-- | Display a warning if a condition is met.
+warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM ()
+warnTcM reason warn_if_true warn_msg
+ | warn_if_true = addWarnTcM reason warn_msg
+ | otherwise = return ()
+
+-- | Display a warning in the current context.
+addWarnTc :: WarnReason -> MsgDoc -> TcM ()
+addWarnTc reason msg
+ = do { env0 <- tcInitTidyEnv ;
+ addWarnTcM reason (env0, msg) }
+
+-- | Display a warning in a given context.
+addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM ()
+addWarnTcM reason (env0, msg)
+ = do { ctxt <- getErrCtxt ;
+ err_info <- mkErrInfo env0 ctxt ;
+ add_warn reason msg err_info }
+
+-- | Display a warning for the current source location.
+addWarn :: WarnReason -> MsgDoc -> TcRn ()
+addWarn reason msg = add_warn reason msg Outputable.empty
+
+-- | Display a warning for a given source location.
+addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn ()
+addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty
+
+-- | Display a warning, with an optional flag, for the current source
+-- location.
+add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn ()
+add_warn reason msg extra_info
+ = do { loc <- getSrcSpanM
+ ; add_warn_at reason loc msg extra_info }
+
+-- | Display a warning, with an optional flag, for a given location.
+add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
+add_warn_at reason loc msg extra_info
+ = do { dflags <- getDynFlags ;
+ printer <- getPrintUnqualified dflags ;
+ let { warn = mkLongWarnMsg dflags loc printer
+ msg extra_info } ;
+ reportWarning reason warn }
+
+
+{-
+-----------------------------------
+ Other helper functions
+-}
+
+add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan
+ -> [ErrCtxt]
+ -> TcM ()
+add_err_tcm tidy_env err_msg loc ctxt
+ = do { err_info <- mkErrInfo tidy_env ctxt ;
+ addLongErrAt loc err_msg err_info }
+
+mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
+-- Tidy the error info, trimming excessive contexts
+mkErrInfo env ctxts
+-- = do
+-- dbg <- hasPprDebug <$> getDynFlags
+-- if dbg -- In -dppr-debug style the output
+-- then return empty -- just becomes too voluminous
+-- else go dbg 0 env ctxts
+ = go False 0 env ctxts
+ where
+ go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
+ go _ _ _ [] = return empty
+ go dbg n env ((is_landmark, ctxt) : ctxts)
+ | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg
+ = do { (env', msg) <- ctxt env
+ ; let n' = if is_landmark then n else n+1
+ ; rest <- go dbg n' env' ctxts
+ ; return (msg $$ rest) }
+ | otherwise
+ = go dbg n env ctxts
+
+mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts
+mAX_CONTEXTS = 3
+
+-- debugTc is useful for monadic debugging code
+
+debugTc :: TcM () -> TcM ()
+debugTc thing
+ | debugIsOn = thing
+ | otherwise = return ()
+
+{-
+************************************************************************
+* *
+ Type constraints
+* *
+************************************************************************
+-}
+
+addTopEvBinds :: Bag EvBind -> TcM a -> TcM a
+addTopEvBinds new_ev_binds thing_inside
+ =updGblEnv upd_env thing_inside
+ where
+ upd_env tcg_env = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env
+ `unionBags` new_ev_binds }
+
+newTcEvBinds :: TcM EvBindsVar
+newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap
+ ; tcvs_ref <- newTcRef emptyVarSet
+ ; uniq <- newUnique
+ ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
+ ; return (EvBindsVar { ebv_binds = binds_ref
+ , ebv_tcvs = tcvs_ref
+ , ebv_uniq = uniq }) }
+
+-- | Creates an EvBindsVar incapable of holding any bindings. It still
+-- tracks covar usages (see comments on ebv_tcvs in GHC.Tc.Types.Evidence), thus
+-- must be made monadically
+newNoTcEvBinds :: TcM EvBindsVar
+newNoTcEvBinds
+ = do { tcvs_ref <- newTcRef emptyVarSet
+ ; uniq <- newUnique
+ ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq)
+ ; return (CoEvBindsVar { ebv_tcvs = tcvs_ref
+ , ebv_uniq = uniq }) }
+
+cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar
+-- Clone the refs, so that any binding created when
+-- solving don't pollute the original
+cloneEvBindsVar ebv@(EvBindsVar {})
+ = do { binds_ref <- newTcRef emptyEvBindMap
+ ; tcvs_ref <- newTcRef emptyVarSet
+ ; return (ebv { ebv_binds = binds_ref
+ , ebv_tcvs = tcvs_ref }) }
+cloneEvBindsVar ebv@(CoEvBindsVar {})
+ = do { tcvs_ref <- newTcRef emptyVarSet
+ ; return (ebv { ebv_tcvs = tcvs_ref }) }
+
+getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet
+getTcEvTyCoVars ev_binds_var
+ = readTcRef (ebv_tcvs ev_binds_var)
+
+getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
+getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref })
+ = readTcRef ev_ref
+getTcEvBindsMap (CoEvBindsVar {})
+ = return emptyEvBindMap
+
+setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM ()
+setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds
+ = writeTcRef ev_ref binds
+setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds
+ | isEmptyEvBindMap ev_binds
+ = return ()
+ | otherwise
+ = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds)
+
+addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
+-- Add a binding to the TcEvBinds by side effect
+addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind
+ = do { traceTc "addTcEvBind" $ ppr u $$
+ ppr ev_bind
+ ; bnds <- readTcRef ev_ref
+ ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
+addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind
+ = pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u)
+
+chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
+chooseUniqueOccTc fn =
+ do { env <- getGblEnv
+ ; let dfun_n_var = tcg_dfun_n env
+ ; set <- readTcRef dfun_n_var
+ ; let occ = fn set
+ ; writeTcRef dfun_n_var (extendOccSet set occ)
+ ; return occ }
+
+getConstraintVar :: TcM (TcRef WantedConstraints)
+getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
+
+setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
+setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
+
+emitStaticConstraints :: WantedConstraints -> TcM ()
+emitStaticConstraints static_lie
+ = do { gbl_env <- getGblEnv
+ ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) }
+
+emitConstraints :: WantedConstraints -> TcM ()
+emitConstraints ct
+ | isEmptyWC ct
+ = return ()
+ | otherwise
+ = do { lie_var <- getConstraintVar ;
+ updTcRef lie_var (`andWC` ct) }
+
+emitSimple :: Ct -> TcM ()
+emitSimple ct
+ = do { lie_var <- getConstraintVar ;
+ updTcRef lie_var (`addSimples` unitBag ct) }
+
+emitSimples :: Cts -> TcM ()
+emitSimples cts
+ = do { lie_var <- getConstraintVar ;
+ updTcRef lie_var (`addSimples` cts) }
+
+emitImplication :: Implication -> TcM ()
+emitImplication ct
+ = do { lie_var <- getConstraintVar ;
+ updTcRef lie_var (`addImplics` unitBag ct) }
+
+emitImplications :: Bag Implication -> TcM ()
+emitImplications ct
+ = unless (isEmptyBag ct) $
+ do { lie_var <- getConstraintVar ;
+ updTcRef lie_var (`addImplics` ct) }
+
+emitInsoluble :: Ct -> TcM ()
+emitInsoluble ct
+ = do { traceTc "emitInsoluble" (ppr ct)
+ ; lie_var <- getConstraintVar
+ ; updTcRef lie_var (`addInsols` unitBag ct) }
+
+emitInsolubles :: Cts -> TcM ()
+emitInsolubles cts
+ | isEmptyBag cts = return ()
+ | otherwise = do { traceTc "emitInsolubles" (ppr cts)
+ ; lie_var <- getConstraintVar
+ ; updTcRef lie_var (`addInsols` cts) }
+
+-- | Throw out any constraints emitted by the thing_inside
+discardConstraints :: TcM a -> TcM a
+discardConstraints thing_inside = fst <$> captureConstraints thing_inside
+
+-- | The name says it all. The returned TcLevel is the *inner* TcLevel.
+pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
+pushLevelAndCaptureConstraints thing_inside
+ = do { env <- getLclEnv
+ ; let tclvl' = pushTcLevel (tcl_tclvl env)
+ ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl')
+ ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $
+ captureConstraints thing_inside
+ ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl')
+ ; return (tclvl', lie, res) }
+
+pushTcLevelM_ :: TcM a -> TcM a
+pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x
+
+pushTcLevelM :: TcM a -> TcM (TcLevel, a)
+-- See Note [TcLevel assignment] in GHC.Tc.Utils.TcType
+pushTcLevelM thing_inside
+ = do { env <- getLclEnv
+ ; let tclvl' = pushTcLevel (tcl_tclvl env)
+ ; res <- setLclEnv (env { tcl_tclvl = tclvl' })
+ thing_inside
+ ; return (tclvl', res) }
+
+-- Returns pushed TcLevel
+pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel)
+pushTcLevelsM num_levels thing_inside
+ = do { env <- getLclEnv
+ ; let tclvl' = nTimes num_levels pushTcLevel (tcl_tclvl env)
+ ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) $
+ thing_inside
+ ; return (res, tclvl') }
+
+getTcLevel :: TcM TcLevel
+getTcLevel = do { env <- getLclEnv
+ ; return (tcl_tclvl env) }
+
+setTcLevel :: TcLevel -> TcM a -> TcM a
+setTcLevel tclvl thing_inside
+ = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside
+
+isTouchableTcM :: TcTyVar -> TcM Bool
+isTouchableTcM tv
+ = do { lvl <- getTcLevel
+ ; return (isTouchableMetaTyVar lvl tv) }
+
+getLclTypeEnv :: TcM TcTypeEnv
+getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
+
+setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
+-- Set the local type envt, but do *not* disturb other fields,
+-- notably the lie_var
+setLclTypeEnv lcl_env thing_inside
+ = updLclEnv upd thing_inside
+ where
+ upd env = env { tcl_env = tcl_env lcl_env }
+
+traceTcConstraints :: String -> TcM ()
+traceTcConstraints msg
+ = do { lie_var <- getConstraintVar
+ ; lie <- readTcRef lie_var
+ ; traceOptTcRn Opt_D_dump_tc_trace $
+ hang (text (msg ++ ": LIE:")) 2 (ppr lie)
+ }
+
+emitAnonWildCardHoleConstraint :: TcTyVar -> TcM ()
+emitAnonWildCardHoleConstraint tv
+ = do { ct_loc <- getCtLocM HoleOrigin Nothing
+ ; emitInsolubles $ unitBag $
+ CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv
+ , ctev_loc = ct_loc }
+ , cc_occ = mkTyVarOcc "_"
+ , cc_hole = TypeHole } }
+
+emitNamedWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
+emitNamedWildCardHoleConstraints wcs
+ = do { ct_loc <- getCtLocM HoleOrigin Nothing
+ ; emitInsolubles $ listToBag $
+ map (do_one ct_loc) wcs }
+ where
+ do_one :: CtLoc -> (Name, TcTyVar) -> Ct
+ do_one ct_loc (name, tv)
+ = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv
+ , ctev_loc = ct_loc' }
+ , cc_occ = occName name
+ , cc_hole = TypeHole }
+ where
+ real_span = case nameSrcSpan name of
+ RealSrcSpan span _ -> span
+ UnhelpfulSpan str -> pprPanic "emitNamedWildCardHoleConstraints"
+ (ppr name <+> quotes (ftext str))
+ -- Wildcards are defined locally, and so have RealSrcSpans
+ ct_loc' = setCtLocSpan ct_loc real_span
+
+{- Note [Constraints and errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (#12124):
+
+ foo :: Maybe Int
+ foo = return (case Left 3 of
+ Left -> 1 -- Hard error here!
+ _ -> 0)
+
+The call to 'return' will generate a (Monad m) wanted constraint; but
+then there'll be "hard error" (i.e. an exception in the TcM monad), from
+the unsaturated Left constructor pattern.
+
+We'll recover in tcPolyBinds, using recoverM. But then the final
+tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly
+un-filled-in, and will emit a misleading error message.
+
+The underlying problem is that an exception interrupts the constraint
+gathering process. Bottom line: if we have an exception, it's best
+simply to discard any gathered constraints. Hence in 'attemptM' we
+capture the constraints in a fresh variable, and only emit them into
+the surrounding context if we exit normally. If an exception is
+raised, simply discard the collected constraints... we have a hard
+error to report. So this capture-the-emit dance isn't as stupid as it
+looks :-).
+
+However suppose we throw an exception inside an invocation of
+captureConstraints, and discard all the constraints. Some of those
+constraints might be "variable out of scope" Hole constraints, and that
+might have been the actual original cause of the exception! For
+example (#12529):
+ f = p @ Int
+Here 'p' is out of scope, so we get an insoluble Hole constraint. But
+the visible type application fails in the monad (throws an exception).
+We must not discard the out-of-scope error.
+
+So we /retain the insoluble constraints/ if there is an exception.
+Hence:
+ - insolublesOnly in tryCaptureConstraints
+ - emitConstraints in the Left case of captureConstraints
+
+However note that freshly-generated constraints like (Int ~ Bool), or
+((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as
+insoluble. The constraint solver does that. So they'll be discarded.
+That's probably ok; but see th/5358 as a not-so-good example:
+ t1 :: Int
+ t1 x = x -- Manifestly wrong
+
+ foo = $(...raises exception...)
+We report the exception, but not the bug in t1. Oh well. Possible
+solution: make GHC.Tc.Utils.Unify.uType spot manifestly-insoluble constraints.
+
+
+************************************************************************
+* *
+ Template Haskell context
+* *
+************************************************************************
+-}
+
+recordThUse :: TcM ()
+recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
+
+recordThSpliceUse :: TcM ()
+recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
+
+keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set
+keepAlive name
+ = do { env <- getGblEnv
+ ; traceRn "keep alive" (ppr name)
+ ; updTcRef (tcg_keep env) (`extendNameSet` name) }
+
+getStage :: TcM ThStage
+getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
+
+getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
+getStageAndBindLevel name
+ = do { env <- getLclEnv;
+ ; case lookupNameEnv (tcl_th_bndrs env) name of
+ Nothing -> return Nothing
+ Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }
+
+setStage :: ThStage -> TcM a -> TcRn a
+setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
+
+-- | Adds the given modFinalizers to the global environment and set them to use
+-- the current local environment.
+addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
+addModFinalizersWithLclEnv mod_finalizers
+ = do lcl_env <- getLclEnv
+ th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
+ updTcRef th_modfinalizers_var $ \fins ->
+ (lcl_env, mod_finalizers) : fins
+
+{-
+************************************************************************
+* *
+ Safe Haskell context
+* *
+************************************************************************
+-}
+
+-- | Mark that safe inference has failed
+-- See Note [Safe Haskell Overlapping Instances Implementation]
+-- although this is used for more than just that failure case.
+recordUnsafeInfer :: WarningMessages -> TcM ()
+recordUnsafeInfer warns =
+ getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)
+
+-- | Figure out the final correct safe haskell mode
+finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
+finalSafeMode dflags tcg_env = do
+ safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)
+ return $ case safeHaskell dflags of
+ Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred
+ | otherwise -> Sf_None
+ s -> s
+
+-- | Switch instances to safe instances if we're in Safe mode.
+fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
+fixSafeInstances sfMode | sfMode /= Sf_Safe && sfMode /= Sf_SafeInferred = id
+fixSafeInstances _ = map fixSafe
+ where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }
+ in inst { is_flag = new_flag }
+
+{-
+************************************************************************
+* *
+ Stuff for the renamer's local env
+* *
+************************************************************************
+-}
+
+getLocalRdrEnv :: RnM LocalRdrEnv
+getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
+
+setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
+setLocalRdrEnv rdr_env thing_inside
+ = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
+
+{-
+************************************************************************
+* *
+ Stuff for interface decls
+* *
+************************************************************************
+-}
+
+mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv
+mkIfLclEnv mod loc boot
+ = IfLclEnv { if_mod = mod,
+ if_loc = loc,
+ if_boot = boot,
+ if_nsubst = Nothing,
+ if_implicits_env = Nothing,
+ if_tv_env = emptyFsEnv,
+ if_id_env = emptyFsEnv }
+
+-- | Run an 'IfG' (top-level interface monad) computation inside an existing
+-- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
+-- based on 'TcGblEnv'.
+initIfaceTcRn :: IfG a -> TcRn a
+initIfaceTcRn thing_inside
+ = do { tcg_env <- getGblEnv
+ ; dflags <- getDynFlags
+ ; let !mod = tcg_semantic_mod tcg_env
+ -- When we are instantiating a signature, we DEFINITELY
+ -- do not want to knot tie.
+ is_instantiate = unitIdIsDefinite (thisPackage dflags) &&
+ not (null (thisUnitIdInsts dflags))
+ ; let { if_env = IfGblEnv {
+ if_doc = text "initIfaceTcRn",
+ if_rec_types =
+ if is_instantiate
+ then Nothing
+ else Just (mod, get_type_env)
+ }
+ ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
+ ; setEnvs (if_env, ()) thing_inside }
+
+-- Used when sucking in a ModIface into a ModDetails to put in
+-- the HPT. Notably, unlike initIfaceCheck, this does NOT use
+-- hsc_type_env_var (since we're not actually going to typecheck,
+-- so this variable will never get updated!)
+initIfaceLoad :: HscEnv -> IfG a -> IO a
+initIfaceLoad hsc_env do_this
+ = do let gbl_env = IfGblEnv {
+ if_doc = text "initIfaceLoad",
+ if_rec_types = Nothing
+ }
+ initTcRnIf 'i' hsc_env gbl_env () do_this
+
+initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a
+-- Used when checking the up-to-date-ness of the old Iface
+-- Initialise the environment with no useful info at all
+initIfaceCheck doc hsc_env do_this
+ = do let rec_types = case hsc_type_env_var hsc_env of
+ Just (mod,var) -> Just (mod, readTcRef var)
+ Nothing -> Nothing
+ gbl_env = IfGblEnv {
+ if_doc = text "initIfaceCheck" <+> doc,
+ if_rec_types = rec_types
+ }
+ initTcRnIf 'i' hsc_env gbl_env () do_this
+
+initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a
+initIfaceLcl mod loc_doc hi_boot_file thing_inside
+ = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside
+
+-- | Initialize interface typechecking, but with a 'NameShape'
+-- to apply when typechecking top-level 'OccName's (see
+-- 'lookupIfaceTop')
+initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a
+initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside
+ = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside
+
+getIfModule :: IfL Module
+getIfModule = do { env <- getLclEnv; return (if_mod env) }
+
+--------------------
+failIfM :: MsgDoc -> IfL a
+-- The Iface monad doesn't have a place to accumulate errors, so we
+-- just fall over fast if one happens; it "shouldn't happen".
+-- We use IfL here so that we can get context info out of the local env
+failIfM msg
+ = do { env <- getLclEnv
+ ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
+ ; dflags <- getDynFlags
+ ; liftIO (putLogMsg dflags NoReason SevFatal
+ noSrcSpan (defaultErrStyle dflags) full_msg)
+ ; failM }
+
+--------------------
+forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
+-- Run thing_inside in an interleaved thread.
+-- It shares everything with the parent thread, so this is DANGEROUS.
+--
+-- It returns Nothing if the computation fails
+--
+-- It's used for lazily type-checking interface
+-- signatures, which is pretty benign
+
+forkM_maybe doc thing_inside
+ = do { -- see Note [Masking exceptions in forkM_maybe]
+ ; unsafeInterleaveM $ uninterruptibleMaskM_ $
+ do { traceIf (text "Starting fork {" <+> doc)
+ ; mb_res <- tryM $
+ updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
+ thing_inside
+ ; case mb_res of
+ Right r -> do { traceIf (text "} ending fork" <+> doc)
+ ; return (Just r) }
+ Left exn -> do {
+
+ -- Bleat about errors in the forked thread, if -ddump-if-trace is on
+ -- Otherwise we silently discard errors. Errors can legitimately
+ -- happen when compiling interface signatures (see tcInterfaceSigs)
+ whenDOptM Opt_D_dump_if_trace $ do
+ dflags <- getDynFlags
+ let msg = hang (text "forkM failed:" <+> doc)
+ 2 (text (show exn))
+ liftIO $ putLogMsg dflags
+ NoReason
+ SevFatal
+ noSrcSpan
+ (defaultErrStyle dflags)
+ msg
+
+ ; traceIf (text "} ending fork (badly)" <+> doc)
+ ; return Nothing }
+ }}
+
+forkM :: SDoc -> IfL a -> IfL a
+forkM doc thing_inside
+ = do { mb_res <- forkM_maybe doc thing_inside
+ ; return (case mb_res of
+ Nothing -> pgmError "Cannot continue after interface file error"
+ -- pprPanic "forkM" doc
+ Just r -> r) }
+
+setImplicitEnvM :: TypeEnv -> IfL a -> IfL a
+setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl
+ { if_implicits_env = Just tenv }) m
+
+{-
+Note [Masking exceptions in forkM_maybe]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When using GHC-as-API it must be possible to interrupt snippets of code
+executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible
+by throwing an asynchronous interrupt to the GHC thread. However, there is a
+subtle problem: runStmt first typechecks the code before running it, and the
+exception might interrupt the type checker rather than the code. Moreover, the
+typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and
+more importantly might be inside an exception handler inside that
+unsafeInterleaveIO. If that is the case, the exception handler will rethrow the
+asynchronous exception as a synchronous exception, and the exception will end
+up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
+discussion). We don't currently know a general solution to this problem, but
+we can use uninterruptibleMask_ to avoid the situation.
+-}
+
+-- | Environments which track 'CostCentreState'
+class ContainsCostCentreState e where
+ extractCostCentreState :: e -> TcRef CostCentreState
+
+instance ContainsCostCentreState TcGblEnv where
+ extractCostCentreState = tcg_cc_st
+
+instance ContainsCostCentreState DsGblEnv where
+ extractCostCentreState = ds_cc_st
+
+-- | Get the next cost centre index associated with a given name.
+getCCIndexM :: (ContainsCostCentreState gbl)
+ => FastString -> TcRnIf gbl lcl CostCentreIndex
+getCCIndexM nm = do
+ env <- getGblEnv
+ let cc_st_ref = extractCostCentreState env
+ cc_st <- readTcRef cc_st_ref
+ let (idx, cc_st') = getCCIndex nm cc_st
+ writeTcRef cc_st_ref cc_st'
+ return idx
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs
new file mode 100644
index 0000000000..1469170847
--- /dev/null
+++ b/compiler/GHC/Tc/Utils/TcMType.hs
@@ -0,0 +1,2419 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+-}
+
+{-# LANGUAGE CPP, TupleSections, MultiWayIf #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+
+-- | Monadic type operations
+--
+-- This module contains monadic operations over types that contain mutable type
+-- variables.
+module GHC.Tc.Utils.TcMType (
+ TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet,
+
+ --------------------------------
+ -- Creating new mutable type variables
+ newFlexiTyVar,
+ newNamedFlexiTyVar,
+ newFlexiTyVarTy, -- Kind -> TcM TcType
+ newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType]
+ newOpenFlexiTyVarTy, newOpenTypeKind,
+ newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel,
+ cloneMetaTyVar,
+ newFmvTyVar, newFskTyVar,
+
+ readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
+ newMetaDetails, isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar,
+
+ --------------------------------
+ -- Expected types
+ ExpType(..), ExpSigmaType, ExpRhoType,
+ mkCheckExpType,
+ newInferExpType, newInferExpTypeInst, newInferExpTypeNoInst,
+ readExpType, readExpType_maybe,
+ expTypeToType, checkingExpType_maybe, checkingExpType,
+ tauifyExpType, inferResultToType,
+
+ --------------------------------
+ -- Creating new evidence variables
+ newEvVar, newEvVars, newDict,
+ newWanted, newWanteds, newHoleCt, cloneWanted, cloneWC,
+ emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars,
+ emitDerivedEqs,
+ newTcEvBinds, newNoTcEvBinds, addTcEvBind,
+
+ newCoercionHole, fillCoercionHole, isFilledCoercionHole,
+ unpackCoercionHole, unpackCoercionHole_maybe,
+ checkCoercionHole,
+
+ newImplication,
+
+ --------------------------------
+ -- Instantiation
+ newMetaTyVars, newMetaTyVarX, newMetaTyVarsX,
+ newMetaTyVarTyVars, newMetaTyVarTyVarX,
+ newTyVarTyVar, cloneTyVarTyVar,
+ newPatSigTyVar, newSkolemTyVar, newWildCardX,
+ tcInstType,
+ tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt,
+ tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX,
+
+ freshenTyVarBndrs, freshenCoVarBndrsX,
+
+ --------------------------------
+ -- Zonking and tidying
+ zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin,
+ tidyEvVar, tidyCt, tidySkolemInfo,
+ zonkTcTyVar, zonkTcTyVars,
+ zonkTcTyVarToTyVar, zonkTyVarTyVarPairs,
+ zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV,
+ zonkTyCoVarsAndFVList,
+ candidateQTyVarsOfType, candidateQTyVarsOfKind,
+ candidateQTyVarsOfTypes, candidateQTyVarsOfKinds,
+ CandidatesQTvs(..), delCandidates, candidateKindVars, partitionCandidates,
+ zonkAndSkolemise, skolemiseQuantifiedTyVar,
+ defaultTyVar, quantifyTyVars, isQuantifiableTv,
+ zonkTcType, zonkTcTypes, zonkCo,
+ zonkTyCoVarKind,
+
+ zonkEvVar, zonkWC, zonkSimples,
+ zonkId, zonkCoVar,
+ zonkCt, zonkSkolemInfo,
+
+ skolemiseUnboundMetaTyVar,
+
+ ------------------------------
+ -- Levity polymorphism
+ ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr
+ ) where
+
+#include "HsVersions.h"
+
+-- friends:
+import GhcPrelude
+
+import GHC.Core.TyCo.Rep
+import GHC.Core.TyCo.Ppr
+import GHC.Tc.Utils.TcType
+import GHC.Core.Type
+import GHC.Core.TyCon
+import GHC.Core.Coercion
+import GHC.Core.Class
+import GHC.Types.Var
+import GHC.Core.Predicate
+import GHC.Tc.Types.Origin
+
+-- others:
+import GHC.Tc.Utils.Monad -- TcType, amongst others
+import GHC.Tc.Types.Constraint
+import GHC.Tc.Types.Evidence
+import GHC.Types.Id as Id
+import GHC.Types.Name
+import GHC.Types.Var.Set
+import TysWiredIn
+import TysPrim
+import GHC.Types.Var.Env
+import GHC.Types.Name.Env
+import PrelNames
+import Util
+import Outputable
+import FastString
+import Bag
+import Pair
+import GHC.Types.Unique.Set
+import GHC.Driver.Session
+import qualified GHC.LanguageExtensions as LangExt
+import GHC.Types.Basic ( TypeOrKind(..) )
+
+import Control.Monad
+import Maybes
+import Data.List ( mapAccumL )
+import Control.Arrow ( second )
+import qualified Data.Semigroup as Semi
+
+{-
+************************************************************************
+* *
+ Kind variables
+* *
+************************************************************************
+-}
+
+mkKindName :: Unique -> Name
+mkKindName unique = mkSystemName unique kind_var_occ
+
+kind_var_occ :: OccName -- Just one for all MetaKindVars
+ -- They may be jiggled by tidying
+kind_var_occ = mkOccName tvName "k"
+
+newMetaKindVar :: TcM TcKind
+newMetaKindVar
+ = do { details <- newMetaDetails TauTv
+ ; uniq <- newUnique
+ ; let kv = mkTcTyVar (mkKindName uniq) liftedTypeKind details
+ ; traceTc "newMetaKindVar" (ppr kv)
+ ; return (mkTyVarTy kv) }
+
+newMetaKindVars :: Int -> TcM [TcKind]
+newMetaKindVars n = replicateM n newMetaKindVar
+
+{-
+************************************************************************
+* *
+ Evidence variables; range over constraints we can abstract over
+* *
+************************************************************************
+-}
+
+newEvVars :: TcThetaType -> TcM [EvVar]
+newEvVars theta = mapM newEvVar theta
+
+--------------
+
+newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar
+-- Creates new *rigid* variables for predicates
+newEvVar ty = do { name <- newSysName (predTypeOccName ty)
+ ; return (mkLocalIdOrCoVar name ty) }
+
+newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence
+-- Deals with both equality and non-equality predicates
+newWanted orig t_or_k pty
+ = do loc <- getCtLocM orig t_or_k
+ d <- if isEqPrimPred pty then HoleDest <$> newCoercionHole YesBlockSubst pty
+ else EvVarDest <$> newEvVar pty
+ return $ CtWanted { ctev_dest = d
+ , ctev_pred = pty
+ , ctev_nosh = WDeriv
+ , ctev_loc = loc }
+
+newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence]
+newWanteds orig = mapM (newWanted orig Nothing)
+
+-- | Create a new 'CHoleCan' 'Ct'.
+newHoleCt :: HoleSort -> Id -> Type -> TcM Ct
+newHoleCt hole ev ty = do
+ loc <- getCtLocM HoleOrigin Nothing
+ pure $ CHoleCan { cc_ev = CtWanted { ctev_pred = ty
+ , ctev_dest = EvVarDest ev
+ , ctev_nosh = WDeriv
+ , ctev_loc = loc }
+ , cc_occ = getOccName ev
+ , cc_hole = hole }
+
+----------------------------------------------
+-- Cloning constraints
+----------------------------------------------
+
+cloneWanted :: Ct -> TcM Ct
+cloneWanted ct
+ | ev@(CtWanted { ctev_dest = HoleDest old_hole, ctev_pred = pty }) <- ctEvidence ct
+ = do { co_hole <- newCoercionHole (ch_blocker old_hole) pty
+ ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) }
+ | otherwise
+ = return ct
+
+cloneWC :: WantedConstraints -> TcM WantedConstraints
+-- Clone all the evidence bindings in
+-- a) the ic_bind field of any implications
+-- b) the CoercionHoles of any wanted constraints
+-- so that solving the WantedConstraints will not have any visible side
+-- effect, /except/ from causing unifications
+cloneWC wc@(WC { wc_simple = simples, wc_impl = implics })
+ = do { simples' <- mapBagM cloneWanted simples
+ ; implics' <- mapBagM cloneImplication implics
+ ; return (wc { wc_simple = simples', wc_impl = implics' }) }
+
+cloneImplication :: Implication -> TcM Implication
+cloneImplication implic@(Implic { ic_binds = binds, ic_wanted = inner_wanted })
+ = do { binds' <- cloneEvBindsVar binds
+ ; inner_wanted' <- cloneWC inner_wanted
+ ; return (implic { ic_binds = binds', ic_wanted = inner_wanted' }) }
+
+----------------------------------------------
+-- Emitting constraints
+----------------------------------------------
+
+-- | Emits a new Wanted. Deals with both equalities and non-equalities.
+emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm
+emitWanted origin pty
+ = do { ev <- newWanted origin Nothing pty
+ ; emitSimple $ mkNonCanonical ev
+ ; return $ ctEvTerm ev }
+
+emitDerivedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM ()
+-- Emit some new derived nominal equalities
+emitDerivedEqs origin pairs
+ | null pairs
+ = return ()
+ | otherwise
+ = do { loc <- getCtLocM origin Nothing
+ ; emitSimples (listToBag (map (mk_one loc) pairs)) }
+ where
+ mk_one loc (ty1, ty2)
+ = mkNonCanonical $
+ CtDerived { ctev_pred = mkPrimEqPred ty1 ty2
+ , ctev_loc = loc }
+
+-- | Emits a new equality constraint
+emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion
+emitWantedEq origin t_or_k role ty1 ty2
+ = do { hole <- newCoercionHole YesBlockSubst pty
+ ; loc <- getCtLocM origin (Just t_or_k)
+ ; emitSimple $ mkNonCanonical $
+ CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole
+ , ctev_nosh = WDeriv, ctev_loc = loc }
+ ; return (HoleCo hole) }
+ where
+ pty = mkPrimEqPredRole role ty1 ty2
+
+-- | Creates a new EvVar and immediately emits it as a Wanted.
+-- No equality predicates here.
+emitWantedEvVar :: CtOrigin -> TcPredType -> TcM EvVar
+emitWantedEvVar origin ty
+ = do { new_cv <- newEvVar ty
+ ; loc <- getCtLocM origin Nothing
+ ; let ctev = CtWanted { ctev_dest = EvVarDest new_cv
+ , ctev_pred = ty
+ , ctev_nosh = WDeriv
+ , ctev_loc = loc }
+ ; emitSimple $ mkNonCanonical ctev
+ ; return new_cv }
+
+emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar]
+emitWantedEvVars orig = mapM (emitWantedEvVar orig)
+
+newDict :: Class -> [TcType] -> TcM DictId
+newDict cls tys
+ = do { name <- newSysName (mkDictOcc (getOccName cls))
+ ; return (mkLocalId name (mkClassPred cls tys)) }
+
+predTypeOccName :: PredType -> OccName
+predTypeOccName ty = case classifyPredType ty of
+ ClassPred cls _ -> mkDictOcc (getOccName cls)
+ EqPred {} -> mkVarOccFS (fsLit "co")
+ IrredPred {} -> mkVarOccFS (fsLit "irred")
+ ForAllPred {} -> mkVarOccFS (fsLit "df")
+
+-- | Create a new 'Implication' with as many sensible defaults for its fields
+-- as possible. Note that the 'ic_tclvl', 'ic_binds', and 'ic_info' fields do
+-- /not/ have sensible defaults, so they are initialized with lazy thunks that
+-- will 'panic' if forced, so one should take care to initialize these fields
+-- after creation.
+--
+-- This is monadic to look up the 'TcLclEnv', which is used to initialize
+-- 'ic_env', and to set the -Winaccessible-code flag. See
+-- Note [Avoid -Winaccessible-code when deriving] in GHC.Tc.TyCl.Instance.
+newImplication :: TcM Implication
+newImplication
+ = do env <- getLclEnv
+ warn_inaccessible <- woptM Opt_WarnInaccessibleCode
+ return (implicationPrototype { ic_env = env
+ , ic_warn_inaccessible = warn_inaccessible })
+
+{-
+************************************************************************
+* *
+ Coercion holes
+* *
+************************************************************************
+-}
+
+newCoercionHole :: BlockSubstFlag -- should the presence of this hole block substitution?
+ -- See sub-wrinkle in TcCanonical
+ -- Note [Equalities with incompatible kinds]
+ -> TcPredType -> TcM CoercionHole
+newCoercionHole blocker pred_ty
+ = do { co_var <- newEvVar pred_ty
+ ; traceTc "New coercion hole:" (ppr co_var <+> ppr blocker)
+ ; ref <- newMutVar Nothing
+ ; return $ CoercionHole { ch_co_var = co_var, ch_blocker = blocker
+ , ch_ref = ref } }
+
+-- | Put a value in a coercion hole
+fillCoercionHole :: CoercionHole -> Coercion -> TcM ()
+fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co
+ = do {
+#if defined(DEBUG)
+ ; cts <- readTcRef ref
+ ; whenIsJust cts $ \old_co ->
+ pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co)
+#endif
+ ; traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co)
+ ; writeTcRef ref (Just co) }
+
+-- | Is a coercion hole filled in?
+isFilledCoercionHole :: CoercionHole -> TcM Bool
+isFilledCoercionHole (CoercionHole { ch_ref = ref }) = isJust <$> readTcRef ref
+
+-- | Retrieve the contents of a coercion hole. Panics if the hole
+-- is unfilled
+unpackCoercionHole :: CoercionHole -> TcM Coercion
+unpackCoercionHole hole
+ = do { contents <- unpackCoercionHole_maybe hole
+ ; case contents of
+ Just co -> return co
+ Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) }
+
+-- | Retrieve the contents of a coercion hole, if it is filled
+unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion)
+unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref
+
+-- | Check that a coercion is appropriate for filling a hole. (The hole
+-- itself is needed only for printing.
+-- Always returns the checked coercion, but this return value is necessary
+-- so that the input coercion is forced only when the output is forced.
+checkCoercionHole :: CoVar -> Coercion -> TcM Coercion
+checkCoercionHole cv co
+ | debugIsOn
+ = do { cv_ty <- zonkTcType (varType cv)
+ -- co is already zonked, but cv might not be
+ ; return $
+ ASSERT2( ok cv_ty
+ , (text "Bad coercion hole" <+>
+ ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role
+ , ppr cv_ty ]) )
+ co }
+ | otherwise
+ = return co
+
+ where
+ (Pair t1 t2, role) = coercionKindRole co
+ ok cv_ty | EqPred cv_rel cv_t1 cv_t2 <- classifyPredType cv_ty
+ = t1 `eqType` cv_t1
+ && t2 `eqType` cv_t2
+ && role == eqRelRole cv_rel
+ | otherwise
+ = False
+
+{-
+************************************************************************
+*
+ Expected types
+*
+************************************************************************
+
+Note [ExpType]
+~~~~~~~~~~~~~~
+
+An ExpType is used as the "expected type" when type-checking an expression.
+An ExpType can hold a "hole" that can be filled in by the type-checker.
+This allows us to have one tcExpr that works in both checking mode and
+synthesis mode (that is, bidirectional type-checking). Previously, this
+was achieved by using ordinary unification variables, but we don't need
+or want that generality. (For example, #11397 was caused by doing the
+wrong thing with unification variables.) Instead, we observe that these
+holes should
+
+1. never be nested
+2. never appear as the type of a variable
+3. be used linearly (never be duplicated)
+
+By defining ExpType, separately from Type, we can achieve goals 1 and 2
+statically.
+
+See also [wiki:typechecking]
+
+Note [TcLevel of ExpType]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+ data G a where
+ MkG :: G Bool
+
+ foo MkG = True
+
+This is a classic untouchable-variable / ambiguous GADT return type
+scenario. But, with ExpTypes, we'll be inferring the type of the RHS.
+And, because there is only one branch of the case, we won't trigger
+Note [Case branches must never infer a non-tau type] of GHC.Tc.Gen.Match.
+We thus must track a TcLevel in an Inferring ExpType. If we try to
+fill the ExpType and find that the TcLevels don't work out, we
+fill the ExpType with a tau-tv at the low TcLevel, hopefully to
+be worked out later by some means. This is triggered in
+test gadt/gadt-escape1.
+
+-}
+
+-- actual data definition is in GHC.Tc.Utils.TcType
+
+-- | Make an 'ExpType' suitable for inferring a type of kind * or #.
+newInferExpTypeNoInst :: TcM ExpSigmaType
+newInferExpTypeNoInst = newInferExpType False
+
+newInferExpTypeInst :: TcM ExpRhoType
+newInferExpTypeInst = newInferExpType True
+
+newInferExpType :: Bool -> TcM ExpType
+newInferExpType inst
+ = do { u <- newUnique
+ ; tclvl <- getTcLevel
+ ; traceTc "newOpenInferExpType" (ppr u <+> ppr inst <+> ppr tclvl)
+ ; ref <- newMutVar Nothing
+ ; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl
+ , ir_ref = ref, ir_inst = inst })) }
+
+-- | Extract a type out of an ExpType, if one exists. But one should always
+-- exist. Unless you're quite sure you know what you're doing.
+readExpType_maybe :: ExpType -> TcM (Maybe TcType)
+readExpType_maybe (Check ty) = return (Just ty)
+readExpType_maybe (Infer (IR { ir_ref = ref})) = readMutVar ref
+
+-- | Extract a type out of an ExpType. Otherwise, panics.
+readExpType :: ExpType -> TcM TcType
+readExpType exp_ty
+ = do { mb_ty <- readExpType_maybe exp_ty
+ ; case mb_ty of
+ Just ty -> return ty
+ Nothing -> pprPanic "Unknown expected type" (ppr exp_ty) }
+
+-- | Returns the expected type when in checking mode.
+checkingExpType_maybe :: ExpType -> Maybe TcType
+checkingExpType_maybe (Check ty) = Just ty
+checkingExpType_maybe _ = Nothing
+
+-- | Returns the expected type when in checking mode. Panics if in inference
+-- mode.
+checkingExpType :: String -> ExpType -> TcType
+checkingExpType _ (Check ty) = ty
+checkingExpType err et = pprPanic "checkingExpType" (text err $$ ppr et)
+
+tauifyExpType :: ExpType -> TcM ExpType
+-- ^ Turn a (Infer hole) type into a (Check alpha),
+-- where alpha is a fresh unification variable
+tauifyExpType (Check ty) = return (Check ty) -- No-op for (Check ty)
+tauifyExpType (Infer inf_res) = do { ty <- inferResultToType inf_res
+ ; return (Check ty) }
+
+-- | Extracts the expected type if there is one, or generates a new
+-- TauTv if there isn't.
+expTypeToType :: ExpType -> TcM TcType
+expTypeToType (Check ty) = return ty
+expTypeToType (Infer inf_res) = inferResultToType inf_res
+
+inferResultToType :: InferResult -> TcM Type
+inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl
+ , ir_ref = ref })
+ = do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy
+ ; tau <- newMetaTyVarTyAtLevel tc_lvl (tYPE rr)
+ -- See Note [TcLevel of ExpType]
+ ; writeMutVar ref (Just tau)
+ ; traceTc "Forcing ExpType to be monomorphic:"
+ (ppr u <+> text ":=" <+> ppr tau)
+ ; return tau }
+
+
+{- *********************************************************************
+* *
+ SkolemTvs (immutable)
+* *
+********************************************************************* -}
+
+tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar]))
+ -- ^ How to instantiate the type variables
+ -> Id -- ^ Type to instantiate
+ -> TcM ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result
+ -- (type vars, preds (incl equalities), rho)
+tcInstType inst_tyvars id
+ = case tcSplitForAllTys (idType id) of
+ ([], rho) -> let -- There may be overloading despite no type variables;
+ -- (?x :: Int) => Int -> Int
+ (theta, tau) = tcSplitPhiTy rho
+ in
+ return ([], theta, tau)
+
+ (tyvars, rho) -> do { (subst, tyvars') <- inst_tyvars tyvars
+ ; let (theta, tau) = tcSplitPhiTy (substTyAddInScope subst rho)
+ tv_prs = map tyVarName tyvars `zip` tyvars'
+ ; return (tv_prs, theta, tau) }
+
+tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType)
+-- Instantiate a type signature with skolem constants.
+-- We could give them fresh names, but no need to do so
+tcSkolDFunType dfun
+ = do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun
+ ; return (map snd tv_prs, theta, tau) }
+
+tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar])
+-- Make skolem constants, but do *not* give them new names, as above
+-- Moreover, make them "super skolems"; see comments with superSkolemTv
+-- see Note [Kind substitution when instantiating]
+-- Precondition: tyvars should be ordered by scoping
+tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar emptyTCvSubst
+
+tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar)
+tcSuperSkolTyVar subst tv
+ = (extendTvSubstWithClone subst tv new_tv, new_tv)
+ where
+ kind = substTyUnchecked subst (tyVarKind tv)
+ new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv
+
+-- | Given a list of @['TyVar']@, skolemize the type variables,
+-- returning a substitution mapping the original tyvars to the
+-- skolems, and the list of newly bound skolems.
+tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- See Note [Skolemising type variables]
+tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst
+
+tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- See Note [Skolemising type variables]
+tcInstSkolTyVarsX = tcInstSkolTyVarsPushLevel False
+
+tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- See Note [Skolemising type variables]
+tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst
+
+tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- See Note [Skolemising type variables]
+tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst
+
+tcInstSkolTyVarsPushLevel :: Bool -> TCvSubst -> [TyVar]
+ -> TcM (TCvSubst, [TcTyVar])
+-- Skolemise one level deeper, hence pushTcLevel
+-- See Note [Skolemising type variables]
+tcInstSkolTyVarsPushLevel overlappable subst tvs
+ = do { tc_lvl <- getTcLevel
+ ; let pushed_lvl = pushTcLevel tc_lvl
+ ; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs }
+
+tcInstSkolTyVarsAt :: TcLevel -> Bool
+ -> TCvSubst -> [TyVar]
+ -> TcM (TCvSubst, [TcTyVar])
+tcInstSkolTyVarsAt lvl overlappable subst tvs
+ = freshenTyCoVarsX new_skol_tv subst tvs
+ where
+ details = SkolemTv lvl overlappable
+ new_skol_tv name kind = mkTcTyVar name kind details
+
+------------------
+freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar])
+-- ^ Give fresh uniques to a bunch of TyVars, but they stay
+-- as TyVars, rather than becoming TcTyVars
+-- Used in GHC.Tc.Instance.Family.newFamInst, and Inst.newClsInst
+freshenTyVarBndrs = freshenTyCoVars mkTyVar
+
+freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcM (TCvSubst, [CoVar])
+-- ^ Give fresh uniques to a bunch of CoVars
+-- Used in GHC.Tc.Instance.Family.newFamInst
+freshenCoVarBndrsX subst = freshenTyCoVarsX mkCoVar subst
+
+------------------
+freshenTyCoVars :: (Name -> Kind -> TyCoVar)
+ -> [TyVar] -> TcM (TCvSubst, [TyCoVar])
+freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptyTCvSubst
+
+freshenTyCoVarsX :: (Name -> Kind -> TyCoVar)
+ -> TCvSubst -> [TyCoVar]
+ -> TcM (TCvSubst, [TyCoVar])
+freshenTyCoVarsX mk_tcv = mapAccumLM (freshenTyCoVarX mk_tcv)
+
+freshenTyCoVarX :: (Name -> Kind -> TyCoVar)
+ -> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar)
+-- This a complete freshening operation:
+-- the skolems have a fresh unique, and a location from the monad
+-- See Note [Skolemising type variables]
+freshenTyCoVarX mk_tcv subst tycovar
+ = do { loc <- getSrcSpanM
+ ; uniq <- newUnique
+ ; let old_name = tyVarName tycovar
+ new_name = mkInternalName uniq (getOccName old_name) loc
+ new_kind = substTyUnchecked subst (tyVarKind tycovar)
+ new_tcv = mk_tcv new_name new_kind
+ subst1 = extendTCvSubstWithClone subst tycovar new_tcv
+ ; return (subst1, new_tcv) }
+
+{- Note [Skolemising type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The tcInstSkolTyVars family of functions instantiate a list of TyVars
+to fresh skolem TcTyVars. Important notes:
+
+a) Level allocation. We generally skolemise /before/ calling
+ pushLevelAndCaptureConstraints. So we want their level to the level
+ of the soon-to-be-created implication, which has a level ONE HIGHER
+ than the current level. Hence the pushTcLevel. It feels like a
+ slight hack.
+
+b) The [TyVar] should be ordered (kind vars first)
+ See Note [Kind substitution when instantiating]
+
+c) It's a complete freshening operation: the skolems have a fresh
+ unique, and a location from the monad
+
+d) The resulting skolems are
+ non-overlappable for tcInstSkolTyVars,
+ but overlappable for tcInstSuperSkolTyVars
+ See GHC.Tc.Deriv.Infer Note [Overlap and deriving] for an example
+ of where this matters.
+
+Note [Kind substitution when instantiating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we instantiate a bunch of kind and type variables, first we
+expect them to be topologically sorted.
+Then we have to instantiate the kind variables, build a substitution
+from old variables to the new variables, then instantiate the type
+variables substituting the original kind.
+
+Exemple: If we want to instantiate
+ [(k1 :: *), (k2 :: *), (a :: k1 -> k2), (b :: k1)]
+we want
+ [(?k1 :: *), (?k2 :: *), (?a :: ?k1 -> ?k2), (?b :: ?k1)]
+instead of the buggous
+ [(?k1 :: *), (?k2 :: *), (?a :: k1 -> k2), (?b :: k1)]
+
+
+************************************************************************
+* *
+ MetaTvs (meta type variables; mutable)
+* *
+************************************************************************
+-}
+
+{-
+Note [TyVarTv]
+~~~~~~~~~~~~
+
+A TyVarTv can unify with type *variables* only, including other TyVarTvs and
+skolems. Sometimes, they can unify with type variables that the user would
+rather keep distinct; see #11203 for an example. So, any client of this
+function needs to either allow the TyVarTvs to unify with each other or check
+that they don't (say, with a call to findDubTyVarTvs).
+
+Before #15050 this (under the name SigTv) was used for ScopedTypeVariables in
+patterns, to make sure these type variables only refer to other type variables,
+but this restriction was dropped, and ScopedTypeVariables can now refer to full
+types (GHC Proposal 29).
+
+The remaining uses of newTyVarTyVars are
+* In kind signatures, see
+ GHC.Tc.TyCl Note [Inferring kinds for type declarations]
+ and Note [Kind checking for GADTs]
+* In partial type signatures, see Note [Quantified variables in partial type signatures]
+-}
+
+newMetaTyVarName :: FastString -> TcM Name
+-- Makes a /System/ Name, which is eagerly eliminated by
+-- the unifier; see GHC.Tc.Utils.Unify.nicer_to_update_tv1, and
+-- GHC.Tc.Solver.Canonical.canEqTyVarTyVar (nicer_to_update_tv2)
+newMetaTyVarName str
+ = do { uniq <- newUnique
+ ; return (mkSystemName uniq (mkTyVarOccFS str)) }
+
+cloneMetaTyVarName :: Name -> TcM Name
+cloneMetaTyVarName name
+ = do { uniq <- newUnique
+ ; return (mkSystemName uniq (nameOccName name)) }
+ -- See Note [Name of an instantiated type variable]
+
+{- Note [Name of an instantiated type variable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+At the moment we give a unification variable a System Name, which
+influences the way it is tidied; see TypeRep.tidyTyVarBndr.
+-}
+
+metaInfoToTyVarName :: MetaInfo -> FastString
+metaInfoToTyVarName meta_info =
+ case meta_info of
+ TauTv -> fsLit "t"
+ FlatMetaTv -> fsLit "fmv"
+ FlatSkolTv -> fsLit "fsk"
+ TyVarTv -> fsLit "a"
+
+newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar
+newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi
+
+newNamedAnonMetaTyVar :: FastString -> MetaInfo -> Kind -> TcM TcTyVar
+-- Make a new meta tyvar out of thin air
+newNamedAnonMetaTyVar tyvar_name meta_info kind
+
+ = do { name <- newMetaTyVarName tyvar_name
+ ; details <- newMetaDetails meta_info
+ ; let tyvar = mkTcTyVar name kind details
+ ; traceTc "newAnonMetaTyVar" (ppr tyvar)
+ ; return tyvar }
+
+-- makes a new skolem tv
+newSkolemTyVar :: Name -> Kind -> TcM TcTyVar
+newSkolemTyVar name kind
+ = do { lvl <- getTcLevel
+ ; return (mkTcTyVar name kind (SkolemTv lvl False)) }
+
+newTyVarTyVar :: Name -> Kind -> TcM TcTyVar
+-- See Note [TyVarTv]
+-- Does not clone a fresh unique
+newTyVarTyVar name kind
+ = do { details <- newMetaDetails TyVarTv
+ ; let tyvar = mkTcTyVar name kind details
+ ; traceTc "newTyVarTyVar" (ppr tyvar)
+ ; return tyvar }
+
+cloneTyVarTyVar :: Name -> Kind -> TcM TcTyVar
+-- See Note [TyVarTv]
+-- Clones a fresh unique
+cloneTyVarTyVar name kind
+ = do { details <- newMetaDetails TyVarTv
+ ; uniq <- newUnique
+ ; let name' = name `setNameUnique` uniq
+ tyvar = mkTcTyVar name' kind details
+ -- Don't use cloneMetaTyVar, which makes a SystemName
+ -- We want to keep the original more user-friendly Name
+ -- In practical terms that means that in error messages,
+ -- when the Name is tidied we get 'a' rather than 'a0'
+ ; traceTc "cloneTyVarTyVar" (ppr tyvar)
+ ; return tyvar }
+
+newPatSigTyVar :: Name -> Kind -> TcM TcTyVar
+newPatSigTyVar name kind
+ = do { details <- newMetaDetails TauTv
+ ; uniq <- newUnique
+ ; let name' = name `setNameUnique` uniq
+ tyvar = mkTcTyVar name' kind details
+ -- Don't use cloneMetaTyVar;
+ -- same reasoning as in newTyVarTyVar
+ ; traceTc "newPatSigTyVar" (ppr tyvar)
+ ; return tyvar }
+
+cloneAnonMetaTyVar :: MetaInfo -> TyVar -> TcKind -> TcM TcTyVar
+-- Make a fresh MetaTyVar, basing the name
+-- on that of the supplied TyVar
+cloneAnonMetaTyVar info tv kind
+ = do { details <- newMetaDetails info
+ ; name <- cloneMetaTyVarName (tyVarName tv)
+ ; let tyvar = mkTcTyVar name kind details
+ ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar))
+ ; return tyvar }
+
+newFskTyVar :: TcType -> TcM TcTyVar
+newFskTyVar fam_ty
+ = do { details <- newMetaDetails FlatSkolTv
+ ; name <- newMetaTyVarName (fsLit "fsk")
+ ; return (mkTcTyVar name (tcTypeKind fam_ty) details) }
+
+newFmvTyVar :: TcType -> TcM TcTyVar
+-- Very like newMetaTyVar, except sets mtv_tclvl to one less
+-- so that the fmv is untouchable.
+newFmvTyVar fam_ty
+ = do { details <- newMetaDetails FlatMetaTv
+ ; name <- newMetaTyVarName (fsLit "s")
+ ; return (mkTcTyVar name (tcTypeKind fam_ty) details) }
+
+newMetaDetails :: MetaInfo -> TcM TcTyVarDetails
+newMetaDetails info
+ = do { ref <- newMutVar Flexi
+ ; tclvl <- getTcLevel
+ ; return (MetaTv { mtv_info = info
+ , mtv_ref = ref
+ , mtv_tclvl = tclvl }) }
+
+cloneMetaTyVar :: TcTyVar -> TcM TcTyVar
+cloneMetaTyVar tv
+ = ASSERT( isTcTyVar tv )
+ do { ref <- newMutVar Flexi
+ ; name' <- cloneMetaTyVarName (tyVarName tv)
+ ; let details' = case tcTyVarDetails tv of
+ details@(MetaTv {}) -> details { mtv_ref = ref }
+ _ -> pprPanic "cloneMetaTyVar" (ppr tv)
+ tyvar = mkTcTyVar name' (tyVarKind tv) details'
+ ; traceTc "cloneMetaTyVar" (ppr tyvar)
+ ; return tyvar }
+
+-- Works for both type and kind variables
+readMetaTyVar :: TyVar -> TcM MetaDetails
+readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )
+ readMutVar (metaTyVarRef tyvar)
+
+isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type)
+isFilledMetaTyVar_maybe tv
+ | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv
+ = do { cts <- readTcRef ref
+ ; case cts of
+ Indirect ty -> return (Just ty)
+ Flexi -> return Nothing }
+ | otherwise
+ = return Nothing
+
+isFilledMetaTyVar :: TyVar -> TcM Bool
+-- True of a filled-in (Indirect) meta type variable
+isFilledMetaTyVar tv = isJust <$> isFilledMetaTyVar_maybe tv
+
+isUnfilledMetaTyVar :: TyVar -> TcM Bool
+-- True of a un-filled-in (Flexi) meta type variable
+-- NB: Not the opposite of isFilledMetaTyVar
+isUnfilledMetaTyVar tv
+ | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv
+ = do { details <- readMutVar ref
+ ; return (isFlexi details) }
+ | otherwise = return False
+
+--------------------
+-- Works with both type and kind variables
+writeMetaTyVar :: TcTyVar -> TcType -> TcM ()
+-- Write into a currently-empty MetaTyVar
+
+writeMetaTyVar tyvar ty
+ | not debugIsOn
+ = writeMetaTyVarRef tyvar (metaTyVarRef tyvar) ty
+
+-- Everything from here on only happens if DEBUG is on
+ | not (isTcTyVar tyvar)
+ = ASSERT2( False, text "Writing to non-tc tyvar" <+> ppr tyvar )
+ return ()
+
+ | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar
+ = writeMetaTyVarRef tyvar ref ty
+
+ | otherwise
+ = ASSERT2( False, text "Writing to non-meta tyvar" <+> ppr tyvar )
+ return ()
+
+--------------------
+writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()
+-- Here the tyvar is for error checking only;
+-- the ref cell must be for the same tyvar
+writeMetaTyVarRef tyvar ref ty
+ | not debugIsOn
+ = do { traceTc "writeMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)
+ <+> text ":=" <+> ppr ty)
+ ; writeTcRef ref (Indirect ty) }
+
+ -- Everything from here on only happens if DEBUG is on
+ | otherwise
+ = do { meta_details <- readMutVar ref;
+ -- Zonk kinds to allow the error check to work
+ ; zonked_tv_kind <- zonkTcType tv_kind
+ ; zonked_ty_kind <- zonkTcType ty_kind
+ ; let kind_check_ok = tcIsConstraintKind zonked_tv_kind
+ || tcEqKind zonked_ty_kind zonked_tv_kind
+ -- Hack alert! tcIsConstraintKind: see GHC.Tc.Gen.HsType
+ -- Note [Extra-constraint holes in partial type signatures]
+
+ kind_msg = hang (text "Ill-kinded update to meta tyvar")
+ 2 ( ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind)
+ <+> text ":="
+ <+> ppr ty <+> text "::" <+> (ppr zonked_ty_kind) )
+
+ ; traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)
+
+ -- Check for double updates
+ ; MASSERT2( isFlexi meta_details, double_upd_msg meta_details )
+
+ -- Check for level OK
+ -- See Note [Level check when unifying]
+ ; MASSERT2( level_check_ok, level_check_msg )
+
+ -- Check Kinds ok
+ ; MASSERT2( kind_check_ok, kind_msg )
+
+ -- Do the write
+ ; writeMutVar ref (Indirect ty) }
+ where
+ tv_kind = tyVarKind tyvar
+ ty_kind = tcTypeKind ty
+
+ tv_lvl = tcTyVarLevel tyvar
+ ty_lvl = tcTypeLevel ty
+
+ level_check_ok = not (ty_lvl `strictlyDeeperThan` tv_lvl)
+ level_check_msg = ppr ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty
+
+ double_upd_msg details = hang (text "Double update of meta tyvar")
+ 2 (ppr tyvar $$ ppr details)
+
+{- Note [Level check when unifying]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When unifying
+ alpha:lvl := ty
+we expect that the TcLevel of 'ty' will be <= lvl.
+However, during unflatting we do
+ fuv:l := ty:(l+1)
+which is usually wrong; hence the check isFmmvTyVar in level_check_ok.
+See Note [TcLevel assignment] in GHC.Tc.Utils.TcType.
+-}
+
+{-
+% Generating fresh variables for pattern match check
+-}
+
+
+{-
+************************************************************************
+* *
+ MetaTvs: TauTvs
+* *
+************************************************************************
+
+Note [Never need to instantiate coercion variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With coercion variables sloshing around in types, it might seem that we
+sometimes need to instantiate coercion variables. This would be problematic,
+because coercion variables inhabit unboxed equality (~#), and the constraint
+solver thinks in terms only of boxed equality (~). The solution is that
+we never need to instantiate coercion variables in the first place.
+
+The tyvars that we need to instantiate come from the types of functions,
+data constructors, and patterns. These will never be quantified over
+coercion variables, except for the special case of the promoted Eq#. But,
+that can't ever appear in user code, so we're safe!
+-}
+
+
+newFlexiTyVar :: Kind -> TcM TcTyVar
+newFlexiTyVar kind = newAnonMetaTyVar TauTv kind
+
+-- | Create a new flexi ty var with a specific name
+newNamedFlexiTyVar :: FastString -> Kind -> TcM TcTyVar
+newNamedFlexiTyVar fs kind = newNamedAnonMetaTyVar fs TauTv kind
+
+newFlexiTyVarTy :: Kind -> TcM TcType
+newFlexiTyVarTy kind = do
+ tc_tyvar <- newFlexiTyVar kind
+ return (mkTyVarTy tc_tyvar)
+
+newFlexiTyVarTys :: Int -> Kind -> TcM [TcType]
+newFlexiTyVarTys n kind = replicateM n (newFlexiTyVarTy kind)
+
+newOpenTypeKind :: TcM TcKind
+newOpenTypeKind
+ = do { rr <- newFlexiTyVarTy runtimeRepTy
+ ; return (tYPE rr) }
+
+-- | Create a tyvar that can be a lifted or unlifted type.
+-- Returns alpha :: TYPE kappa, where both alpha and kappa are fresh
+newOpenFlexiTyVarTy :: TcM TcType
+newOpenFlexiTyVarTy
+ = do { kind <- newOpenTypeKind
+ ; newFlexiTyVarTy kind }
+
+newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- Instantiate with META type variables
+-- Note that this works for a sequence of kind, type, and coercion variables
+-- variables. Eg [ (k:*), (a:k->k) ]
+-- Gives [ (k7:*), (a8:k7->k7) ]
+newMetaTyVars = newMetaTyVarsX emptyTCvSubst
+ -- emptyTCvSubst has an empty in-scope set, but that's fine here
+ -- Since the tyvars are freshly made, they cannot possibly be
+ -- captured by any existing for-alls.
+
+newMetaTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- Just like newMetaTyVars, but start with an existing substitution.
+newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst
+
+newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
+-- Make a new unification variable tyvar whose Name and Kind come from
+-- an existing TyVar. We substitute kind variables in the kind.
+newMetaTyVarX subst tyvar = new_meta_tv_x TauTv subst tyvar
+
+newMetaTyVarTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
+newMetaTyVarTyVars = mapAccumLM newMetaTyVarTyVarX emptyTCvSubst
+
+newMetaTyVarTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
+-- Just like newMetaTyVarX, but make a TyVarTv
+newMetaTyVarTyVarX subst tyvar = new_meta_tv_x TyVarTv subst tyvar
+
+newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
+newWildCardX subst tv
+ = do { new_tv <- newAnonMetaTyVar TauTv (substTy subst (tyVarKind tv))
+ ; return (extendTvSubstWithClone subst tv new_tv, new_tv) }
+
+new_meta_tv_x :: MetaInfo -> TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
+new_meta_tv_x info subst tv
+ = do { new_tv <- cloneAnonMetaTyVar info tv substd_kind
+ ; let subst1 = extendTvSubstWithClone subst tv new_tv
+ ; return (subst1, new_tv) }
+ where
+ substd_kind = substTyUnchecked subst (tyVarKind tv)
+ -- NOTE: #12549 is fixed so we could use
+ -- substTy here, but the tc_infer_args problem
+ -- is not yet fixed so leaving as unchecked for now.
+ -- OLD NOTE:
+ -- Unchecked because we call newMetaTyVarX from
+ -- tcInstTyBinder, which is called from tcInferApps
+ -- which does not yet take enough trouble to ensure
+ -- the in-scope set is right; e.g. #12785 trips
+ -- if we use substTy here
+
+newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType
+newMetaTyVarTyAtLevel tc_lvl kind
+ = do { ref <- newMutVar Flexi
+ ; name <- newMetaTyVarName (fsLit "p")
+ ; let details = MetaTv { mtv_info = TauTv
+ , mtv_ref = ref
+ , mtv_tclvl = tc_lvl }
+ ; return (mkTyVarTy (mkTcTyVar name kind details)) }
+
+{- *********************************************************************
+* *
+ Finding variables to quantify over
+* *
+********************************************************************* -}
+
+{- Note [Dependent type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In Haskell type inference we quantify over type variables; but we only
+quantify over /kind/ variables when -XPolyKinds is on. Without -XPolyKinds
+we default the kind variables to *.
+
+So, to support this defaulting, and only for that reason, when
+collecting the free vars of a type (in candidateQTyVarsOfType and friends),
+prior to quantifying, we must keep the type and kind variables separate.
+
+But what does that mean in a system where kind variables /are/ type
+variables? It's a fairly arbitrary distinction based on how the
+variables appear:
+
+ - "Kind variables" appear in the kind of some other free variable
+ or in the kind of a locally quantified type variable
+ (forall (a :: kappa). ...) or in the kind of a coercion
+ (a |> (co :: kappa1 ~ kappa2)).
+
+ These are the ones we default to * if -XPolyKinds is off
+
+ - "Type variables" are all free vars that are not kind variables
+
+E.g. In the type T k (a::k)
+ 'k' is a kind variable, because it occurs in the kind of 'a',
+ even though it also appears at "top level" of the type
+ 'a' is a type variable, because it doesn't
+
+We gather these variables using a CandidatesQTvs record:
+ DV { dv_kvs: Variables free in the kind of a free type variable
+ or of a forall-bound type variable
+ , dv_tvs: Variables syntactically free in the type }
+
+So: dv_kvs are the kind variables of the type
+ (dv_tvs - dv_kvs) are the type variable of the type
+
+Note that
+
+* A variable can occur in both.
+ T k (x::k) The first occurrence of k makes it
+ show up in dv_tvs, the second in dv_kvs
+
+* We include any coercion variables in the "dependent",
+ "kind-variable" set because we never quantify over them.
+
+* The "kind variables" might depend on each other; e.g
+ (k1 :: k2), (k2 :: *)
+ The "type variables" do not depend on each other; if
+ one did, it'd be classified as a kind variable!
+
+Note [CandidatesQTvs determinism and order]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Determinism: when we quantify over type variables we decide the
+ order in which they appear in the final type. Because the order of
+ type variables in the type can end up in the interface file and
+ affects some optimizations like worker-wrapper, we want this order to
+ be deterministic.
+
+ To achieve that we use deterministic sets of variables that can be
+ converted to lists in a deterministic order. For more information
+ about deterministic sets see Note [Deterministic UniqFM] in GHC.Types.Unique.DFM.
+
+* Order: as well as being deterministic, we use an
+ accumulating-parameter style for candidateQTyVarsOfType so that we
+ add variables one at a time, left to right. That means we tend to
+ produce the variables in left-to-right order. This is just to make
+ it bit more predictable for the programmer.
+
+Note [Naughty quantification candidates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#14880, dependent/should_compile/T14880-2), suppose
+we are trying to generalise this type:
+
+ forall arg. ... (alpha[tau]:arg) ...
+
+We have a metavariable alpha whose kind mentions a skolem variable
+bound inside the very type we are generalising.
+This can arise while type-checking a user-written type signature
+(see the test case for the full code).
+
+We cannot generalise over alpha! That would produce a type like
+ forall {a :: arg}. forall arg. ...blah...
+The fact that alpha's kind mentions arg renders it completely
+ineligible for generalisation.
+
+However, we are not going to learn any new constraints on alpha,
+because its kind isn't even in scope in the outer context (but see Wrinkle).
+So alpha is entirely unconstrained.
+
+What then should we do with alpha? During generalization, every
+metavariable is either (A) promoted, (B) generalized, or (C) zapped
+(according to Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType).
+
+ * We can't generalise it.
+ * We can't promote it, because its kind prevents that
+ * We can't simply leave it be, because this type is about to
+ go into the typing environment (as the type of some let-bound
+ variable, say), and then chaos erupts when we try to instantiate.
+
+Previously, we zapped it to Any. This worked, but it had the unfortunate
+effect of causing Any sometimes to appear in error messages. If this
+kind of signature happens, the user probably has made a mistake -- no
+one really wants Any in their types. So we now error. This must be
+a hard error (failure in the monad) to avoid other messages from mentioning
+Any.
+
+We do this eager erroring in candidateQTyVars, which always precedes
+generalisation, because at that moment we have a clear picture of what
+skolems are in scope within the type itself (e.g. that 'forall arg').
+
+Wrinkle:
+
+We must make absolutely sure that alpha indeed is not
+from an outer context. (Otherwise, we might indeed learn more information
+about it.) This can be done easily: we just check alpha's TcLevel.
+That level must be strictly greater than the ambient TcLevel in order
+to treat it as naughty. We say "strictly greater than" because the call to
+candidateQTyVars is made outside the bumped TcLevel, as stated in the
+comment to candidateQTyVarsOfType. The level check is done in go_tv
+in collect_cand_qtvs. Skipping this check caused #16517.
+
+-}
+
+data CandidatesQTvs
+ -- See Note [Dependent type variables]
+ -- See Note [CandidatesQTvs determinism and order]
+ --
+ -- Invariants:
+ -- * All variables are fully zonked, including their kinds
+ -- * All variables are at a level greater than the ambient level
+ -- See Note [Use level numbers for quantification]
+ --
+ -- This *can* contain skolems. For example, in `data X k :: k -> Type`
+ -- we need to know that the k is a dependent variable. This is done
+ -- by collecting the candidates in the kind after skolemising. It also
+ -- comes up when generalizing a associated type instance, where instance
+ -- variables are skolems. (Recall that associated type instances are generalized
+ -- independently from their enclosing class instance, and the associated
+ -- type instance may be generalized by more, fewer, or different variables
+ -- than the class instance.)
+ --
+ = DV { dv_kvs :: DTyVarSet -- "kind" metavariables (dependent)
+ , dv_tvs :: DTyVarSet -- "type" metavariables (non-dependent)
+ -- A variable may appear in both sets
+ -- E.g. T k (x::k) The first occurrence of k makes it
+ -- show up in dv_tvs, the second in dv_kvs
+ -- See Note [Dependent type variables]
+
+ , dv_cvs :: CoVarSet
+ -- These are covars. Included only so that we don't repeatedly
+ -- look at covars' kinds in accumulator. Not used by quantifyTyVars.
+ }
+
+instance Semi.Semigroup CandidatesQTvs where
+ (DV { dv_kvs = kv1, dv_tvs = tv1, dv_cvs = cv1 })
+ <> (DV { dv_kvs = kv2, dv_tvs = tv2, dv_cvs = cv2 })
+ = DV { dv_kvs = kv1 `unionDVarSet` kv2
+ , dv_tvs = tv1 `unionDVarSet` tv2
+ , dv_cvs = cv1 `unionVarSet` cv2 }
+
+instance Monoid CandidatesQTvs where
+ mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet, dv_cvs = emptyVarSet }
+ mappend = (Semi.<>)
+
+instance Outputable CandidatesQTvs where
+ ppr (DV {dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs })
+ = text "DV" <+> braces (pprWithCommas id [ text "dv_kvs =" <+> ppr kvs
+ , text "dv_tvs =" <+> ppr tvs
+ , text "dv_cvs =" <+> ppr cvs ])
+
+
+candidateKindVars :: CandidatesQTvs -> TyVarSet
+candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs)
+
+partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (DTyVarSet, CandidatesQTvs)
+partitionCandidates dvs@(DV { dv_kvs = kvs, dv_tvs = tvs }) pred
+ = (extracted, dvs { dv_kvs = rest_kvs, dv_tvs = rest_tvs })
+ where
+ (extracted_kvs, rest_kvs) = partitionDVarSet pred kvs
+ (extracted_tvs, rest_tvs) = partitionDVarSet pred tvs
+ extracted = extracted_kvs `unionDVarSet` extracted_tvs
+
+-- | Gathers free variables to use as quantification candidates (in
+-- 'quantifyTyVars'). This might output the same var
+-- in both sets, if it's used in both a type and a kind.
+-- The variables to quantify must have a TcLevel strictly greater than
+-- the ambient level. (See Wrinkle in Note [Naughty quantification candidates])
+-- See Note [CandidatesQTvs determinism and order]
+-- See Note [Dependent type variables]
+candidateQTyVarsOfType :: TcType -- not necessarily zonked
+ -> TcM CandidatesQTvs
+candidateQTyVarsOfType ty = collect_cand_qtvs ty False emptyVarSet mempty ty
+
+-- | Like 'candidateQTyVarsOfType', but over a list of types
+-- The variables to quantify must have a TcLevel strictly greater than
+-- the ambient level. (See Wrinkle in Note [Naughty quantification candidates])
+candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs
+candidateQTyVarsOfTypes tys = foldlM (\acc ty -> collect_cand_qtvs ty False emptyVarSet acc ty)
+ mempty tys
+
+-- | Like 'candidateQTyVarsOfType', but consider every free variable
+-- to be dependent. This is appropriate when generalizing a *kind*,
+-- instead of a type. (That way, -XNoPolyKinds will default the variables
+-- to Type.)
+candidateQTyVarsOfKind :: TcKind -- Not necessarily zonked
+ -> TcM CandidatesQTvs
+candidateQTyVarsOfKind ty = collect_cand_qtvs ty True emptyVarSet mempty ty
+
+candidateQTyVarsOfKinds :: [TcKind] -- Not necessarily zonked
+ -> TcM CandidatesQTvs
+candidateQTyVarsOfKinds tys = foldM (\acc ty -> collect_cand_qtvs ty True emptyVarSet acc ty)
+ mempty tys
+
+delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs
+delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars
+ = DV { dv_kvs = kvs `delDVarSetList` vars
+ , dv_tvs = tvs `delDVarSetList` vars
+ , dv_cvs = cvs `delVarSetList` vars }
+
+collect_cand_qtvs
+ :: TcType -- original type that we started recurring into; for errors
+ -> Bool -- True <=> consider every fv in Type to be dependent
+ -> VarSet -- Bound variables (locals only)
+ -> CandidatesQTvs -- Accumulating parameter
+ -> Type -- Not necessarily zonked
+ -> TcM CandidatesQTvs
+
+-- Key points:
+-- * Looks through meta-tyvars as it goes;
+-- no need to zonk in advance
+--
+-- * Needs to be monadic anyway, because it handles naughty
+-- quantification; see Note [Naughty quantification candidates]
+--
+-- * Returns fully-zonked CandidateQTvs, including their kinds
+-- so that subsequent dependency analysis (to build a well
+-- scoped telescope) works correctly
+
+collect_cand_qtvs orig_ty is_dep bound dvs ty
+ = go dvs ty
+ where
+ is_bound tv = tv `elemVarSet` bound
+
+ -----------------
+ go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs
+ -- Uses accumulating-parameter style
+ go dv (AppTy t1 t2) = foldlM go dv [t1, t2]
+ go dv (TyConApp _ tys) = foldlM go dv tys
+ go dv (FunTy _ arg res) = foldlM go dv [arg, res]
+ go dv (LitTy {}) = return dv
+ go dv (CastTy ty co) = do dv1 <- go dv ty
+ collect_cand_qtvs_co orig_ty bound dv1 co
+ go dv (CoercionTy co) = collect_cand_qtvs_co orig_ty bound dv co
+
+ go dv (TyVarTy tv)
+ | is_bound tv = return dv
+ | otherwise = do { m_contents <- isFilledMetaTyVar_maybe tv
+ ; case m_contents of
+ Just ind_ty -> go dv ind_ty
+ Nothing -> go_tv dv tv }
+
+ go dv (ForAllTy (Bndr tv _) ty)
+ = do { dv1 <- collect_cand_qtvs orig_ty True bound dv (tyVarKind tv)
+ ; collect_cand_qtvs orig_ty is_dep (bound `extendVarSet` tv) dv1 ty }
+
+ -----------------
+ go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv
+ | tv `elemDVarSet` kvs
+ = return dv -- We have met this tyvar already
+
+ | not is_dep
+ , tv `elemDVarSet` tvs
+ = return dv -- We have met this tyvar already
+
+ | otherwise
+ = do { tv_kind <- zonkTcType (tyVarKind tv)
+ -- This zonk is annoying, but it is necessary, both to
+ -- ensure that the collected candidates have zonked kinds
+ -- (#15795) and to make the naughty check
+ -- (which comes next) works correctly
+
+ ; let tv_kind_vars = tyCoVarsOfType tv_kind
+ ; cur_lvl <- getTcLevel
+ ; if | tcTyVarLevel tv <= cur_lvl
+ -> return dv -- this variable is from an outer context; skip
+ -- See Note [Use level numbers ofor quantification]
+
+ | intersectsVarSet bound tv_kind_vars
+ -- the tyvar must not be from an outer context, but we have
+ -- already checked for this.
+ -- See Note [Naughty quantification candidates]
+ -> do { traceTc "Naughty quantifier" $
+ vcat [ ppr tv <+> dcolon <+> ppr tv_kind
+ , text "bound:" <+> pprTyVars (nonDetEltsUniqSet bound)
+ , text "fvs:" <+> pprTyVars (nonDetEltsUniqSet tv_kind_vars) ]
+
+ ; let escapees = intersectVarSet bound tv_kind_vars
+ ; naughtyQuantification orig_ty tv escapees }
+
+ | otherwise
+ -> do { let tv' = tv `setTyVarKind` tv_kind
+ dv' | is_dep = dv { dv_kvs = kvs `extendDVarSet` tv' }
+ | otherwise = dv { dv_tvs = tvs `extendDVarSet` tv' }
+ -- See Note [Order of accumulation]
+
+ -- See Note [Recurring into kinds for candidateQTyVars]
+ ; collect_cand_qtvs orig_ty True bound dv' tv_kind } }
+
+collect_cand_qtvs_co :: TcType -- original type at top of recursion; for errors
+ -> VarSet -- bound variables
+ -> CandidatesQTvs -> Coercion
+ -> TcM CandidatesQTvs
+collect_cand_qtvs_co orig_ty bound = go_co
+ where
+ go_co dv (Refl ty) = collect_cand_qtvs orig_ty True bound dv ty
+ go_co dv (GRefl _ ty mco) = do dv1 <- collect_cand_qtvs orig_ty True bound dv ty
+ go_mco dv1 mco
+ go_co dv (TyConAppCo _ _ cos) = foldlM go_co dv cos
+ go_co dv (AppCo co1 co2) = foldlM go_co dv [co1, co2]
+ go_co dv (FunCo _ co1 co2) = foldlM go_co dv [co1, co2]
+ go_co dv (AxiomInstCo _ _ cos) = foldlM go_co dv cos
+ go_co dv (AxiomRuleCo _ cos) = foldlM go_co dv cos
+ go_co dv (UnivCo prov _ t1 t2) = do dv1 <- go_prov dv prov
+ dv2 <- collect_cand_qtvs orig_ty True bound dv1 t1
+ collect_cand_qtvs orig_ty True bound dv2 t2
+ go_co dv (SymCo co) = go_co dv co
+ go_co dv (TransCo co1 co2) = foldlM go_co dv [co1, co2]
+ go_co dv (NthCo _ _ co) = go_co dv co
+ go_co dv (LRCo _ co) = go_co dv co
+ go_co dv (InstCo co1 co2) = foldlM go_co dv [co1, co2]
+ go_co dv (KindCo co) = go_co dv co
+ go_co dv (SubCo co) = go_co dv co
+
+ go_co dv (HoleCo hole)
+ = do m_co <- unpackCoercionHole_maybe hole
+ case m_co of
+ Just co -> go_co dv co
+ Nothing -> go_cv dv (coHoleCoVar hole)
+
+ go_co dv (CoVarCo cv) = go_cv dv cv
+
+ go_co dv (ForAllCo tcv kind_co co)
+ = do { dv1 <- go_co dv kind_co
+ ; collect_cand_qtvs_co orig_ty (bound `extendVarSet` tcv) dv1 co }
+
+ go_mco dv MRefl = return dv
+ go_mco dv (MCo co) = go_co dv co
+
+ go_prov dv (PhantomProv co) = go_co dv co
+ go_prov dv (ProofIrrelProv co) = go_co dv co
+ go_prov dv (PluginProv _) = return dv
+
+ go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs
+ go_cv dv@(DV { dv_cvs = cvs }) cv
+ | is_bound cv = return dv
+ | cv `elemVarSet` cvs = return dv
+
+ -- See Note [Recurring into kinds for candidateQTyVars]
+ | otherwise = collect_cand_qtvs orig_ty True bound
+ (dv { dv_cvs = cvs `extendVarSet` cv })
+ (idType cv)
+
+ is_bound tv = tv `elemVarSet` bound
+
+{- Note [Order of accumulation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+You might be tempted (like I was) to use unitDVarSet and mappend
+rather than extendDVarSet. However, the union algorithm for
+deterministic sets depends on (roughly) the size of the sets. The
+elements from the smaller set end up to the right of the elements from
+the larger one. When sets are equal, the left-hand argument to
+`mappend` goes to the right of the right-hand argument.
+
+In our case, if we use unitDVarSet and mappend, we learn that the free
+variables of (a -> b -> c -> d) are [b, a, c, d], and we then quantify
+over them in that order. (The a comes after the b because we union the
+singleton sets as ({a} `mappend` {b}), producing {b, a}. Thereafter,
+the size criterion works to our advantage.) This is just annoying to
+users, so I use `extendDVarSet`, which unambiguously puts the new
+element to the right.
+
+Note that the unitDVarSet/mappend implementation would not be wrong
+against any specification -- just suboptimal and confounding to users.
+
+Note [Recurring into kinds for candidateQTyVars]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+First, read Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs, paying
+attention to the end of the Note about using an empty bound set when
+traversing a variable's kind.
+
+That Note concludes with the recommendation that we empty out the bound
+set when recurring into the kind of a type variable. Yet, we do not do
+this here. I have two tasks in order to convince you that this code is
+right. First, I must show why it is safe to ignore the reasoning in that
+Note. Then, I must show why is is necessary to contradict the reasoning in
+that Note.
+
+Why it is safe: There can be no
+shadowing in the candidateQ... functions: they work on the output of
+type inference, which is seeded by the renamer and its insistence to
+use different Uniques for different variables. (In contrast, the Core
+functions work on the output of optimizations, which may introduce
+shadowing.) Without shadowing, the problem studied by
+Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs cannot happen.
+
+Why it is necessary:
+Wiping the bound set would be just plain wrong here. Consider
+
+ forall k1 k2 (a :: k1). Proxy k2 (a |> (hole :: k1 ~# k2))
+
+We really don't want to think k1 and k2 are free here. (It's true that we'll
+never be able to fill in `hole`, but we don't want to go off the rails just
+because we have an insoluble coercion hole.) So: why is it wrong to wipe
+the bound variables here but right in Core? Because the final statement
+in Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs is wrong: not
+every variable is either free or bound. A variable can be a hole, too!
+The reasoning in that Note then breaks down.
+
+And the reasoning applies just as well to free non-hole variables, so we
+retain the bound set always.
+
+-}
+
+{- *********************************************************************
+* *
+ Quantification
+* *
+************************************************************************
+
+Note [quantifyTyVars]
+~~~~~~~~~~~~~~~~~~~~~
+quantifyTyVars is given the free vars of a type that we
+are about to wrap in a forall.
+
+It takes these free type/kind variables (partitioned into dependent and
+non-dependent variables) skolemises metavariables with a TcLevel greater
+than the ambient level (see Note [Use level numbers of quantification]).
+
+* This function distinguishes between dependent and non-dependent
+ variables only to keep correct defaulting behavior with -XNoPolyKinds.
+ With -XPolyKinds, it treats both classes of variables identically.
+
+* quantifyTyVars never quantifies over
+ - a coercion variable (or any tv mentioned in the kind of a covar)
+ - a runtime-rep variable
+
+Note [Use level numbers for quantification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The level numbers assigned to metavariables are very useful. Not only
+do they track touchability (Note [TcLevel and untouchable type variables]
+in GHC.Tc.Utils.TcType), but they also allow us to determine which variables to
+generalise. The rule is this:
+
+ When generalising, quantify only metavariables with a TcLevel greater
+ than the ambient level.
+
+This works because we bump the level every time we go inside a new
+source-level construct. In a traditional generalisation algorithm, we
+would gather all free variables that aren't free in an environment.
+However, if a variable is in that environment, it will always have a lower
+TcLevel: it came from an outer scope. So we can replace the "free in
+environment" check with a level-number check.
+
+Here is an example:
+
+ f x = x + (z True)
+ where
+ z y = x * x
+
+We start by saying (x :: alpha[1]). When inferring the type of z, we'll
+quickly discover that z :: alpha[1]. But it would be disastrous to
+generalise over alpha in the type of z. So we need to know that alpha
+comes from an outer environment. By contrast, the type of y is beta[2],
+and we are free to generalise over it. What's the difference between
+alpha[1] and beta[2]? Their levels. beta[2] has the right TcLevel for
+generalisation, and so we generalise it. alpha[1] does not, and so
+we leave it alone.
+
+Note that not *every* variable with a higher level will get generalised,
+either due to the monomorphism restriction or other quirks. See, for
+example, the code in GHC.Tc.Solver.decideMonoTyVars and in
+GHC.Tc.Gen.HsType.kindGeneralizeSome, both of which exclude certain otherwise-eligible
+variables from being generalised.
+
+Using level numbers for quantification is implemented in the candidateQTyVars...
+functions, by adding only those variables with a level strictly higher than
+the ambient level to the set of candidates.
+
+Note [quantifyTyVars determinism]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The results of quantifyTyVars are wrapped in a forall and can end up in the
+interface file. One such example is inferred type signatures. They also affect
+the results of optimizations, for example worker-wrapper. This means that to
+get deterministic builds quantifyTyVars needs to be deterministic.
+
+To achieve this CandidatesQTvs is backed by deterministic sets which allows them
+to be later converted to a list in a deterministic order.
+
+For more information about deterministic sets see
+Note [Deterministic UniqFM] in GHC.Types.Unique.DFM.
+-}
+
+quantifyTyVars
+ :: CandidatesQTvs -- See Note [Dependent type variables]
+ -- Already zonked
+ -> TcM [TcTyVar]
+-- See Note [quantifyTyVars]
+-- Can be given a mixture of TcTyVars and TyVars, in the case of
+-- associated type declarations. Also accepts covars, but *never* returns any.
+-- According to Note [Use level numbers for quantification] and the
+-- invariants on CandidateQTvs, we do not have to filter out variables
+-- free in the environment here. Just quantify unconditionally, subject
+-- to the restrictions in Note [quantifyTyVars].
+quantifyTyVars dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs })
+ -- short-circuit common case
+ | isEmptyDVarSet dep_tkvs
+ , isEmptyDVarSet nondep_tkvs
+ = do { traceTc "quantifyTyVars has nothing to quantify" empty
+ ; return [] }
+
+ | otherwise
+ = do { traceTc "quantifyTyVars 1" (ppr dvs)
+
+ ; let dep_kvs = scopedSort $ dVarSetElems dep_tkvs
+ -- scopedSort: put the kind variables into
+ -- well-scoped order.
+ -- E.g. [k, (a::k)] not the other way round
+
+ nondep_tvs = dVarSetElems (nondep_tkvs `minusDVarSet` dep_tkvs)
+ -- See Note [Dependent type variables]
+ -- The `minus` dep_tkvs removes any kind-level vars
+ -- e.g. T k (a::k) Since k appear in a kind it'll
+ -- be in dv_kvs, and is dependent. So remove it from
+ -- dv_tvs which will also contain k
+ -- NB kinds of tvs are zonked by zonkTyCoVarsAndFV
+
+ -- In the non-PolyKinds case, default the kind variables
+ -- to *, and zonk the tyvars as usual. Notice that this
+ -- may make quantifyTyVars return a shorter list
+ -- than it was passed, but that's ok
+ ; poly_kinds <- xoptM LangExt.PolyKinds
+ ; dep_kvs' <- mapMaybeM (zonk_quant (not poly_kinds)) dep_kvs
+ ; nondep_tvs' <- mapMaybeM (zonk_quant False) nondep_tvs
+ ; let final_qtvs = dep_kvs' ++ nondep_tvs'
+ -- Because of the order, any kind variables
+ -- mentioned in the kinds of the nondep_tvs'
+ -- now refer to the dep_kvs'
+
+ ; traceTc "quantifyTyVars 2"
+ (vcat [ text "nondep:" <+> pprTyVars nondep_tvs
+ , text "dep:" <+> pprTyVars dep_kvs
+ , text "dep_kvs'" <+> pprTyVars dep_kvs'
+ , text "nondep_tvs'" <+> pprTyVars nondep_tvs' ])
+
+ -- We should never quantify over coercion variables; check this
+ ; let co_vars = filter isCoVar final_qtvs
+ ; MASSERT2( null co_vars, ppr co_vars )
+
+ ; return final_qtvs }
+ where
+ -- zonk_quant returns a tyvar if it should be quantified over;
+ -- otherwise, it returns Nothing. The latter case happens for
+ -- * Kind variables, with -XNoPolyKinds: don't quantify over these
+ -- * RuntimeRep variables: we never quantify over these
+ zonk_quant default_kind tkv
+ | not (isTyVar tkv)
+ = return Nothing -- this can happen for a covar that's associated with
+ -- a coercion hole. Test case: typecheck/should_compile/T2494
+
+ | not (isTcTyVar tkv)
+ = return (Just tkv) -- For associated types in a class with a standalone
+ -- kind signature, we have the class variables in
+ -- scope, and they are TyVars not TcTyVars
+ | otherwise
+ = do { deflt_done <- defaultTyVar default_kind tkv
+ ; case deflt_done of
+ True -> return Nothing
+ False -> do { tv <- skolemiseQuantifiedTyVar tkv
+ ; return (Just tv) } }
+
+isQuantifiableTv :: TcLevel -- Level of the context, outside the quantification
+ -> TcTyVar
+ -> Bool
+isQuantifiableTv outer_tclvl tcv
+ | isTcTyVar tcv -- Might be a CoVar; change this when gather covars separately
+ = tcTyVarLevel tcv > outer_tclvl
+ | otherwise
+ = False
+
+zonkAndSkolemise :: TcTyCoVar -> TcM TcTyCoVar
+-- A tyvar binder is never a unification variable (TauTv),
+-- rather it is always a skolem. It *might* be a TyVarTv.
+-- (Because non-CUSK type declarations use TyVarTvs.)
+-- Regardless, it may have a kind that has not yet been zonked,
+-- and may include kind unification variables.
+zonkAndSkolemise tyvar
+ | isTyVarTyVar tyvar
+ -- We want to preserve the binding location of the original TyVarTv.
+ -- This is important for error messages. If we don't do this, then
+ -- we get bad locations in, e.g., typecheck/should_fail/T2688
+ = do { zonked_tyvar <- zonkTcTyVarToTyVar tyvar
+ ; skolemiseQuantifiedTyVar zonked_tyvar }
+
+ | otherwise
+ = ASSERT2( isImmutableTyVar tyvar || isCoVar tyvar, pprTyVar tyvar )
+ zonkTyCoVarKind tyvar
+
+skolemiseQuantifiedTyVar :: TcTyVar -> TcM TcTyVar
+-- The quantified type variables often include meta type variables
+-- we want to freeze them into ordinary type variables
+-- The meta tyvar is updated to point to the new skolem TyVar. Now any
+-- bound occurrences of the original type variable will get zonked to
+-- the immutable version.
+--
+-- We leave skolem TyVars alone; they are immutable.
+--
+-- This function is called on both kind and type variables,
+-- but kind variables *only* if PolyKinds is on.
+
+skolemiseQuantifiedTyVar tv
+ = case tcTyVarDetails tv of
+ SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv)
+ ; return (setTyVarKind tv kind) }
+ -- It might be a skolem type variable,
+ -- for example from a user type signature
+
+ MetaTv {} -> skolemiseUnboundMetaTyVar tv
+
+ _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk
+
+defaultTyVar :: Bool -- True <=> please default this kind variable to *
+ -> TcTyVar -- If it's a MetaTyVar then it is unbound
+ -> TcM Bool -- True <=> defaulted away altogether
+
+defaultTyVar default_kind tv
+ | not (isMetaTyVar tv)
+ = return False
+
+ | isTyVarTyVar tv
+ -- Do not default TyVarTvs. Doing so would violate the invariants
+ -- on TyVarTvs; see Note [Signature skolems] in GHC.Tc.Utils.TcType.
+ -- #13343 is an example; #14555 is another
+ -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl
+ = return False
+
+
+ | isRuntimeRepVar tv -- Do not quantify over a RuntimeRep var
+ -- unless it is a TyVarTv, handled earlier
+ = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv)
+ ; writeMetaTyVar tv liftedRepTy
+ ; return True }
+
+ | default_kind -- -XNoPolyKinds and this is a kind var
+ = default_kind_var tv -- so default it to * if possible
+
+ | otherwise
+ = return False
+
+ where
+ default_kind_var :: TyVar -> TcM Bool
+ -- defaultKindVar is used exclusively with -XNoPolyKinds
+ -- See Note [Defaulting with -XNoPolyKinds]
+ -- It takes an (unconstrained) meta tyvar and defaults it.
+ -- Works only on vars of type *; for other kinds, it issues an error.
+ default_kind_var kv
+ | isLiftedTypeKind (tyVarKind kv)
+ = do { traceTc "Defaulting a kind var to *" (ppr kv)
+ ; writeMetaTyVar kv liftedTypeKind
+ ; return True }
+ | otherwise
+ = do { addErr (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv')
+ , text "of kind:" <+> ppr (tyVarKind kv')
+ , text "Perhaps enable PolyKinds or add a kind signature" ])
+ -- We failed to default it, so return False to say so.
+ -- Hence, it'll get skolemised. That might seem odd, but we must either
+ -- promote, skolemise, or zap-to-Any, to satisfy GHC.Tc.Gen.HsType
+ -- Note [Recipe for checking a signature]
+ -- Otherwise we get level-number assertion failures. It doesn't matter much
+ -- because we are in an error situation anyway.
+ ; return False
+ }
+ where
+ (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv
+
+skolemiseUnboundMetaTyVar :: TcTyVar -> TcM TyVar
+-- We have a Meta tyvar with a ref-cell inside it
+-- Skolemise it, so that we are totally out of Meta-tyvar-land
+-- We create a skolem TcTyVar, not a regular TyVar
+-- See Note [Zonking to Skolem]
+skolemiseUnboundMetaTyVar tv
+ = ASSERT2( isMetaTyVar tv, ppr tv )
+ do { when debugIsOn (check_empty tv)
+ ; here <- getSrcSpanM -- Get the location from "here"
+ -- ie where we are generalising
+ ; kind <- zonkTcType (tyVarKind tv)
+ ; let tv_name = tyVarName tv
+ -- See Note [Skolemising and identity]
+ final_name | isSystemName tv_name
+ = mkInternalName (nameUnique tv_name)
+ (nameOccName tv_name) here
+ | otherwise
+ = tv_name
+ final_tv = mkTcTyVar final_name kind details
+
+ ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv)
+ ; writeMetaTyVar tv (mkTyVarTy final_tv)
+ ; return final_tv }
+
+ where
+ details = SkolemTv (metaTyVarTcLevel tv) False
+ check_empty tv -- [Sept 04] Check for non-empty.
+ = when debugIsOn $ -- See note [Silly Type Synonym]
+ do { cts <- readMetaTyVar tv
+ ; case cts of
+ Flexi -> return ()
+ Indirect ty -> WARN( True, ppr tv $$ ppr ty )
+ return () }
+
+{- Note [Defaulting with -XNoPolyKinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+ data Compose f g a = Mk (f (g a))
+
+We infer
+
+ Compose :: forall k1 k2. (k2 -> *) -> (k1 -> k2) -> k1 -> *
+ Mk :: forall k1 k2 (f :: k2 -> *) (g :: k1 -> k2) (a :: k1).
+ f (g a) -> Compose k1 k2 f g a
+
+Now, in another module, we have -XNoPolyKinds -XDataKinds in effect.
+What does 'Mk mean? Pre GHC-8.0 with -XNoPolyKinds,
+we just defaulted all kind variables to *. But that's no good here,
+because the kind variables in 'Mk aren't of kind *, so defaulting to *
+is ill-kinded.
+
+After some debate on #11334, we decided to issue an error in this case.
+The code is in defaultKindVar.
+
+Note [What is a meta variable?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A "meta type-variable", also know as a "unification variable" is a placeholder
+introduced by the typechecker for an as-yet-unknown monotype.
+
+For example, when we see a call `reverse (f xs)`, we know that we calling
+ reverse :: forall a. [a] -> [a]
+So we know that the argument `f xs` must be a "list of something". But what is
+the "something"? We don't know until we explore the `f xs` a bit more. So we set
+out what we do know at the call of `reverse` by instantiating its type with a fresh
+meta tyvar, `alpha` say. So now the type of the argument `f xs`, and of the
+result, is `[alpha]`. The unification variable `alpha` stands for the
+as-yet-unknown type of the elements of the list.
+
+As type inference progresses we may learn more about `alpha`. For example, suppose
+`f` has the type
+ f :: forall b. b -> [Maybe b]
+Then we instantiate `f`'s type with another fresh unification variable, say
+`beta`; and equate `f`'s result type with reverse's argument type, thus
+`[alpha] ~ [Maybe beta]`.
+
+Now we can solve this equality to learn that `alpha ~ Maybe beta`, so we've
+refined our knowledge about `alpha`. And so on.
+
+If you found this Note useful, you may also want to have a look at
+Section 5 of "Practical type inference for higher rank types" (Peyton Jones,
+Vytiniotis, Weirich and Shields. J. Functional Programming. 2011).
+
+Note [What is zonking?]
+~~~~~~~~~~~~~~~~~~~~~~~
+GHC relies heavily on mutability in the typechecker for efficient operation.
+For this reason, throughout much of the type checking process meta type
+variables (the MetaTv constructor of TcTyVarDetails) are represented by mutable
+variables (known as TcRefs).
+
+Zonking is the process of ripping out these mutable variables and replacing them
+with a real Type. This involves traversing the entire type expression, but the
+interesting part of replacing the mutable variables occurs in zonkTyVarOcc.
+
+There are two ways to zonk a Type:
+
+ * zonkTcTypeToType, which is intended to be used at the end of type-checking
+ for the final zonk. It has to deal with unfilled metavars, either by filling
+ it with a value like Any or failing (determined by the UnboundTyVarZonker
+ used).
+
+ * zonkTcType, which will happily ignore unfilled metavars. This is the
+ appropriate function to use while in the middle of type-checking.
+
+Note [Zonking to Skolem]
+~~~~~~~~~~~~~~~~~~~~~~~~
+We used to zonk quantified type variables to regular TyVars. However, this
+leads to problems. Consider this program from the regression test suite:
+
+ eval :: Int -> String -> String -> String
+ eval 0 root actual = evalRHS 0 root actual
+
+ evalRHS :: Int -> a
+ evalRHS 0 root actual = eval 0 root actual
+
+It leads to the deferral of an equality (wrapped in an implication constraint)
+
+ forall a. () => ((String -> String -> String) ~ a)
+
+which is propagated up to the toplevel (see GHC.Tc.Solver.tcSimplifyInferCheck).
+In the meantime `a' is zonked and quantified to form `evalRHS's signature.
+This has the *side effect* of also zonking the `a' in the deferred equality
+(which at this point is being handed around wrapped in an implication
+constraint).
+
+Finally, the equality (with the zonked `a') will be handed back to the
+simplifier by GHC.Tc.Module.tcRnSrcDecls calling GHC.Tc.Solver.tcSimplifyTop.
+If we zonk `a' with a regular type variable, we will have this regular type
+variable now floating around in the simplifier, which in many places assumes to
+only see proper TcTyVars.
+
+We can avoid this problem by zonking with a skolem TcTyVar. The
+skolem is rigid (which we require for a quantified variable), but is
+still a TcTyVar that the simplifier knows how to deal with.
+
+Note [Skolemising and identity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In some places, we make a TyVarTv for a binder. E.g.
+ class C a where ...
+As Note [Inferring kinds for type declarations] discusses,
+we make a TyVarTv for 'a'. Later we skolemise it, and we'd
+like to retain its identity, location info etc. (If we don't
+retain its identity we'll have to do some pointless swizzling;
+see GHC.Tc.TyCl.swizzleTcTyConBndrs. If we retain its identity
+but not its location we'll lose the detailed binding site info.
+
+Conclusion: use the Name of the TyVarTv. But we don't want
+to do that when skolemising random unification variables;
+there the location we want is the skolemisation site.
+
+Fortunately we can tell the difference: random unification
+variables have System Names. That's why final_name is
+set based on the isSystemName test.
+
+
+Note [Silly Type Synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+ type C u a = u -- Note 'a' unused
+
+ foo :: (forall a. C u a -> C u a) -> u
+ foo x = ...
+
+ bar :: Num u => u
+ bar = foo (\t -> t + t)
+
+* From the (\t -> t+t) we get type {Num d} => d -> d
+ where d is fresh.
+
+* Now unify with type of foo's arg, and we get:
+ {Num (C d a)} => C d a -> C d a
+ where a is fresh.
+
+* Now abstract over the 'a', but float out the Num (C d a) constraint
+ because it does not 'really' mention a. (see exactTyVarsOfType)
+ The arg to foo becomes
+ \/\a -> \t -> t+t
+
+* So we get a dict binding for Num (C d a), which is zonked to give
+ a = ()
+ [Note Sept 04: now that we are zonking quantified type variables
+ on construction, the 'a' will be frozen as a regular tyvar on
+ quantification, so the floated dict will still have type (C d a).
+ Which renders this whole note moot; happily!]
+
+* Then the \/\a abstraction has a zonked 'a' in it.
+
+All very silly. I think its harmless to ignore the problem. We'll end up with
+a \/\a in the final result but all the occurrences of a will be zonked to ()
+
+************************************************************************
+* *
+ Zonking types
+* *
+************************************************************************
+
+-}
+
+zonkTcTypeAndFV :: TcType -> TcM DTyCoVarSet
+-- Zonk a type and take its free variables
+-- With kind polymorphism it can be essential to zonk *first*
+-- so that we find the right set of free variables. Eg
+-- forall k1. forall (a:k2). a
+-- where k2:=k1 is in the substitution. We don't want
+-- k2 to look free in this type!
+zonkTcTypeAndFV ty
+ = tyCoVarsOfTypeDSet <$> zonkTcType ty
+
+zonkTyCoVar :: TyCoVar -> TcM TcType
+-- Works on TyVars and TcTyVars
+zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv
+ | isTyVar tv = mkTyVarTy <$> zonkTyCoVarKind tv
+ | otherwise = ASSERT2( isCoVar tv, ppr tv )
+ mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv
+ -- Hackily, when typechecking type and class decls
+ -- we have TyVars in scope added (only) in
+ -- GHC.Tc.Gen.HsType.bindTyClTyVars, but it seems
+ -- painful to make them into TcTyVars there
+
+zonkTyCoVarsAndFV :: TyCoVarSet -> TcM TyCoVarSet
+zonkTyCoVarsAndFV tycovars
+ = tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars)
+ -- It's OK to use nonDetEltsUniqSet here because we immediately forget about
+ -- the ordering by turning it into a nondeterministic set and the order
+ -- of zonking doesn't matter for determinism.
+
+zonkDTyCoVarSetAndFV :: DTyCoVarSet -> TcM DTyCoVarSet
+zonkDTyCoVarSetAndFV tycovars
+ = mkDVarSet <$> (zonkTyCoVarsAndFVList $ dVarSetElems tycovars)
+
+-- Takes a list of TyCoVars, zonks them and returns a
+-- deterministically ordered list of their free variables.
+zonkTyCoVarsAndFVList :: [TyCoVar] -> TcM [TyCoVar]
+zonkTyCoVarsAndFVList tycovars
+ = tyCoVarsOfTypesList <$> mapM zonkTyCoVar tycovars
+
+zonkTcTyVars :: [TcTyVar] -> TcM [TcType]
+zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars
+
+----------------- Types
+zonkTyCoVarKind :: TyCoVar -> TcM TyCoVar
+zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv)
+ ; return (setTyVarKind tv kind') }
+
+{-
+************************************************************************
+* *
+ Zonking constraints
+* *
+************************************************************************
+-}
+
+zonkImplication :: Implication -> TcM Implication
+zonkImplication implic@(Implic { ic_skols = skols
+ , ic_given = given
+ , ic_wanted = wanted
+ , ic_info = info })
+ = do { skols' <- mapM zonkTyCoVarKind skols -- Need to zonk their kinds!
+ -- as #7230 showed
+ ; given' <- mapM zonkEvVar given
+ ; info' <- zonkSkolemInfo info
+ ; wanted' <- zonkWCRec wanted
+ ; return (implic { ic_skols = skols'
+ , ic_given = given'
+ , ic_wanted = wanted'
+ , ic_info = info' }) }
+
+zonkEvVar :: EvVar -> TcM EvVar
+zonkEvVar var = do { ty' <- zonkTcType (varType var)
+ ; return (setVarType var ty') }
+
+
+zonkWC :: WantedConstraints -> TcM WantedConstraints
+zonkWC wc = zonkWCRec wc
+
+zonkWCRec :: WantedConstraints -> TcM WantedConstraints
+zonkWCRec (WC { wc_simple = simple, wc_impl = implic })
+ = do { simple' <- zonkSimples simple
+ ; implic' <- mapBagM zonkImplication implic
+ ; return (WC { wc_simple = simple', wc_impl = implic' }) }
+
+zonkSimples :: Cts -> TcM Cts
+zonkSimples cts = do { cts' <- mapBagM zonkCt cts
+ ; traceTc "zonkSimples done:" (ppr cts')
+ ; return cts' }
+
+{- Note [zonkCt behaviour]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+zonkCt tries to maintain the canonical form of a Ct. For example,
+ - a CDictCan should stay a CDictCan;
+ - a CHoleCan should stay a CHoleCan
+ - a CIrredCan should stay a CIrredCan with its cc_status flag intact
+
+Why?, for example:
+- For CDictCan, the @GHC.Tc.Solver.expandSuperClasses@ step, which runs after the
+ simple wanted and plugin loop, looks for @CDictCan@s. If a plugin is in use,
+ constraints are zonked before being passed to the plugin. This means if we
+ don't preserve a canonical form, @expandSuperClasses@ fails to expand
+ superclasses. This is what happened in #11525.
+
+- For CHoleCan, once we forget that it's a hole, we can never recover that info.
+
+- For CIrredCan we want to see if a constraint is insoluble with insolubleWC
+
+On the other hand, we change CTyEqCan to CNonCanonical, because of all of
+CTyEqCan's invariants, which can break during zonking. Besides, the constraint
+will be canonicalised again, so there is little benefit in keeping the
+CTyEqCan structure.
+
+NB: we do not expect to see any CFunEqCans, because zonkCt is only
+called on unflattened constraints.
+
+NB: Constraints are always re-flattened etc by the canonicaliser in
+@GHC.Tc.Solver.Canonical@ even if they come in as CDictCan. Only canonical constraints that
+are actually in the inert set carry all the guarantees. So it is okay if zonkCt
+creates e.g. a CDictCan where the cc_tyars are /not/ function free.
+-}
+
+zonkCt :: Ct -> TcM Ct
+-- See Note [zonkCt behaviour]
+zonkCt ct@(CHoleCan { cc_ev = ev })
+ = do { ev' <- zonkCtEvidence ev
+ ; return $ ct { cc_ev = ev' } }
+
+zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args })
+ = do { ev' <- zonkCtEvidence ev
+ ; args' <- mapM zonkTcType args
+ ; return $ ct { cc_ev = ev', cc_tyargs = args' } }
+
+zonkCt (CTyEqCan { cc_ev = ev })
+ = mkNonCanonical <$> zonkCtEvidence ev
+
+zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_status flag
+ = do { ev' <- zonkCtEvidence ev
+ ; return (ct { cc_ev = ev' }) }
+
+zonkCt ct
+ = ASSERT( not (isCFunEqCan ct) )
+ -- We do not expect to see any CFunEqCans, because zonkCt is only called on
+ -- unflattened constraints.
+ do { fl' <- zonkCtEvidence (ctEvidence ct)
+ ; return (mkNonCanonical fl') }
+
+zonkCtEvidence :: CtEvidence -> TcM CtEvidence
+zonkCtEvidence ctev@(CtGiven { ctev_pred = pred })
+ = do { pred' <- zonkTcType pred
+ ; return (ctev { ctev_pred = pred'}) }
+zonkCtEvidence ctev@(CtWanted { ctev_pred = pred, ctev_dest = dest })
+ = do { pred' <- zonkTcType pred
+ ; let dest' = case dest of
+ EvVarDest ev -> EvVarDest $ setVarType ev pred'
+ -- necessary in simplifyInfer
+ HoleDest h -> HoleDest h
+ ; return (ctev { ctev_pred = pred', ctev_dest = dest' }) }
+zonkCtEvidence ctev@(CtDerived { ctev_pred = pred })
+ = do { pred' <- zonkTcType pred
+ ; return (ctev { ctev_pred = pred' }) }
+
+zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo
+zonkSkolemInfo (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty
+ ; return (SigSkol cx ty' tv_prs) }
+zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys
+ ; return (InferSkol ntys') }
+ where
+ do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') }
+zonkSkolemInfo skol_info = return skol_info
+
+{-
+%************************************************************************
+%* *
+\subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar}
+* *
+* For internal use only! *
+* *
+************************************************************************
+
+-}
+
+-- 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
+zonkTcType :: TcType -> TcM TcType
+zonkTcTypes :: [TcType] -> TcM [TcType]
+zonkCo :: Coercion -> TcM Coercion
+
+(zonkTcType, zonkTcTypes, zonkCo, _)
+ = mapTyCo zonkTcTypeMapper
+
+-- | A suitable TyCoMapper for zonking a type during type-checking,
+-- before all metavars are filled in.
+zonkTcTypeMapper :: TyCoMapper () TcM
+zonkTcTypeMapper = TyCoMapper
+ { tcm_tyvar = const zonkTcTyVar
+ , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv)
+ , tcm_hole = hole
+ , tcm_tycobinder = \_env tv _vis -> ((), ) <$> zonkTyCoVarKind tv
+ , tcm_tycon = zonkTcTyCon }
+ where
+ hole :: () -> CoercionHole -> TcM Coercion
+ hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })
+ = do { contents <- readTcRef ref
+ ; case contents of
+ Just co -> do { co' <- zonkCo co
+ ; checkCoercionHole cv co' }
+ Nothing -> do { cv' <- zonkCoVar cv
+ ; return $ HoleCo (hole { ch_co_var = cv' }) } }
+
+zonkTcTyCon :: TcTyCon -> TcM TcTyCon
+-- Only called on TcTyCons
+-- A non-poly TcTyCon may have unification
+-- variables that need zonking, but poly ones cannot
+zonkTcTyCon tc
+ | tcTyConIsPoly tc = return tc
+ | otherwise = do { tck' <- zonkTcType (tyConKind tc)
+ ; return (setTcTyConKind tc tck') }
+
+zonkTcTyVar :: TcTyVar -> TcM TcType
+-- Simply look through all Flexis
+zonkTcTyVar tv
+ | isTcTyVar tv
+ = case tcTyVarDetails tv of
+ SkolemTv {} -> zonk_kind_and_return
+ RuntimeUnk {} -> zonk_kind_and_return
+ MetaTv { mtv_ref = ref }
+ -> do { cts <- readMutVar ref
+ ; case cts of
+ Flexi -> zonk_kind_and_return
+ Indirect ty -> do { zty <- zonkTcType ty
+ ; writeTcRef ref (Indirect zty)
+ -- See Note [Sharing in zonking]
+ ; return zty } }
+
+ | otherwise -- coercion variable
+ = zonk_kind_and_return
+ where
+ zonk_kind_and_return = do { z_tv <- zonkTyCoVarKind tv
+ ; return (mkTyVarTy z_tv) }
+
+-- Variant that assumes that any result of zonking is still a TyVar.
+-- Should be used only on skolems and TyVarTvs
+zonkTcTyVarToTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar
+zonkTcTyVarToTyVar tv
+ = do { ty <- zonkTcTyVar tv
+ ; let tv' = case tcGetTyVar_maybe ty of
+ Just tv' -> tv'
+ Nothing -> pprPanic "zonkTcTyVarToTyVar"
+ (ppr tv $$ ppr ty)
+ ; return tv' }
+
+zonkTyVarTyVarPairs :: [(Name,TcTyVar)] -> TcM [(Name,TcTyVar)]
+zonkTyVarTyVarPairs prs
+ = mapM do_one prs
+ where
+ do_one (nm, tv) = do { tv' <- zonkTcTyVarToTyVar tv
+ ; return (nm, tv') }
+
+-- 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') }
+
+zonkCoVar :: CoVar -> TcM CoVar
+zonkCoVar = zonkId
+
+{- Note [Sharing in zonking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+ alpha :-> beta :-> gamma :-> ty
+where the ":->" means that the unification variable has been
+filled in with Indirect. Then when zonking alpha, it'd be nice
+to short-circuit beta too, so we end up with
+ alpha :-> zty
+ beta :-> zty
+ gamma :-> zty
+where zty is the zonked version of ty. That way, if we come across
+beta later, we'll have less work to do. (And indeed the same for
+alpha.)
+
+This is easily achieved: just overwrite (Indirect ty) with (Indirect
+zty). Non-systematic perf comparisons suggest that this is a modest
+win.
+
+But c.f Note [Sharing when zonking to Type] in GHC.Tc.Utils.Zonk.
+
+%************************************************************************
+%* *
+ Tidying
+* *
+************************************************************************
+-}
+
+zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
+zonkTidyTcType env ty = do { ty' <- zonkTcType ty
+ ; return (tidyOpenType env ty') }
+
+zonkTidyTcTypes :: TidyEnv -> [TcType] -> TcM (TidyEnv, [TcType])
+zonkTidyTcTypes = zonkTidyTcTypes' []
+ where zonkTidyTcTypes' zs env [] = return (env, reverse zs)
+ zonkTidyTcTypes' zs env (ty:tys)
+ = do { (env', ty') <- zonkTidyTcType env ty
+ ; zonkTidyTcTypes' (ty':zs) env' tys }
+
+zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin)
+zonkTidyOrigin env (GivenOrigin skol_info)
+ = do { skol_info1 <- zonkSkolemInfo skol_info
+ ; let skol_info2 = tidySkolemInfo env skol_info1
+ ; return (env, GivenOrigin skol_info2) }
+zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual = act
+ , uo_expected = exp })
+ = do { (env1, act') <- zonkTidyTcType env act
+ ; (env2, exp') <- zonkTidyTcType env1 exp
+ ; return ( env2, orig { uo_actual = act'
+ , uo_expected = exp' }) }
+zonkTidyOrigin env (KindEqOrigin ty1 m_ty2 orig t_or_k)
+ = do { (env1, ty1') <- zonkTidyTcType env ty1
+ ; (env2, m_ty2') <- case m_ty2 of
+ Just ty2 -> second Just <$> zonkTidyTcType env1 ty2
+ Nothing -> return (env1, Nothing)
+ ; (env3, orig') <- zonkTidyOrigin env2 orig
+ ; return (env3, KindEqOrigin ty1' m_ty2' orig' t_or_k) }
+zonkTidyOrigin env (FunDepOrigin1 p1 o1 l1 p2 o2 l2)
+ = do { (env1, p1') <- zonkTidyTcType env p1
+ ; (env2, p2') <- zonkTidyTcType env1 p2
+ ; return (env2, FunDepOrigin1 p1' o1 l1 p2' o2 l2) }
+zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2)
+ = do { (env1, p1') <- zonkTidyTcType env p1
+ ; (env2, p2') <- zonkTidyTcType env1 p2
+ ; (env3, o1') <- zonkTidyOrigin env2 o1
+ ; return (env3, FunDepOrigin2 p1' o1' p2' l2) }
+zonkTidyOrigin env orig = return (env, orig)
+
+----------------
+tidyCt :: TidyEnv -> Ct -> Ct
+-- Used only in error reporting
+tidyCt env ct
+ = ct { cc_ev = tidy_ev env (ctEvidence ct) }
+ where
+ tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence
+ -- NB: we do not tidy the ctev_evar field because we don't
+ -- show it in error messages
+ tidy_ev env ctev@(CtGiven { ctev_pred = pred })
+ = ctev { ctev_pred = tidyType env pred }
+ tidy_ev env ctev@(CtWanted { ctev_pred = pred })
+ = ctev { ctev_pred = tidyType env pred }
+ tidy_ev env ctev@(CtDerived { ctev_pred = pred })
+ = ctev { ctev_pred = tidyType env pred }
+
+----------------
+tidyEvVar :: TidyEnv -> EvVar -> EvVar
+tidyEvVar env var = setVarType var (tidyType env (varType var))
+
+----------------
+tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo
+tidySkolemInfo env (DerivSkol ty) = DerivSkol (tidyType env ty)
+tidySkolemInfo env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs
+tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids)
+tidySkolemInfo env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty)
+tidySkolemInfo _ info = info
+
+tidySigSkol :: TidyEnv -> UserTypeCtxt
+ -> TcType -> [(Name,TcTyVar)] -> SkolemInfo
+-- We need to take special care when tidying SigSkol
+-- See Note [SigSkol SkolemInfo] in Origin
+tidySigSkol env cx ty tv_prs
+ = SigSkol cx (tidy_ty env ty) tv_prs'
+ where
+ tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs
+ inst_env = mkNameEnv tv_prs'
+
+ tidy_ty env (ForAllTy (Bndr tv vis) ty)
+ = ForAllTy (Bndr tv' vis) (tidy_ty env' ty)
+ where
+ (env', tv') = tidy_tv_bndr env tv
+
+ tidy_ty env ty@(FunTy _ arg res)
+ = ty { ft_arg = tidyType env arg, ft_res = tidy_ty env res }
+
+ tidy_ty env ty = tidyType env ty
+
+ tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)
+ tidy_tv_bndr env@(occ_env, subst) tv
+ | Just tv' <- lookupNameEnv inst_env (tyVarName tv)
+ = ((occ_env, extendVarEnv subst tv tv'), tv')
+
+ | otherwise
+ = tidyVarBndr env tv
+
+-------------------------------------------------------------------------
+{-
+%************************************************************************
+%* *
+ Levity polymorphism checks
+* *
+*************************************************************************
+
+See Note [Levity polymorphism checking] in GHC.HsToCore.Monad
+
+-}
+
+-- | According to the rules around representation polymorphism
+-- (see https://gitlab.haskell.org/ghc/ghc/wikis/no-sub-kinds), no binder
+-- can have a representation-polymorphic type. This check ensures
+-- that we respect this rule. It is a bit regrettable that this error
+-- occurs in zonking, after which we should have reported all errors.
+-- But it's hard to see where else to do it, because this can be discovered
+-- only after all solving is done. And, perhaps most importantly, this
+-- isn't really a compositional property of a type system, so it's
+-- not a terrible surprise that the check has to go in an awkward spot.
+ensureNotLevPoly :: Type -- its zonked type
+ -> SDoc -- where this happened
+ -> TcM ()
+ensureNotLevPoly ty doc
+ = whenNoErrs $ -- sometimes we end up zonking bogus definitions of type
+ -- forall a. a. See, for example, test ghci/scripts/T9140
+ checkForLevPoly doc ty
+
+ -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad
+checkForLevPoly :: SDoc -> Type -> TcM ()
+checkForLevPoly = checkForLevPolyX addErr
+
+checkForLevPolyX :: Monad m
+ => (SDoc -> m ()) -- how to report an error
+ -> SDoc -> Type -> m ()
+checkForLevPolyX add_err extra ty
+ | isTypeLevPoly ty
+ = add_err (formatLevPolyErr ty $$ extra)
+ | otherwise
+ = return ()
+
+formatLevPolyErr :: Type -- levity-polymorphic type
+ -> SDoc
+formatLevPolyErr ty
+ = hang (text "A levity-polymorphic type is not allowed here:")
+ 2 (vcat [ text "Type:" <+> pprWithTYPE tidy_ty
+ , text "Kind:" <+> pprWithTYPE tidy_ki ])
+ where
+ (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty
+ tidy_ki = tidyType tidy_env (tcTypeKind ty)
+
+{-
+%************************************************************************
+%* *
+ Error messages
+* *
+*************************************************************************
+
+-}
+
+-- See Note [Naughty quantification candidates]
+naughtyQuantification :: TcType -- original type user wanted to quantify
+ -> TcTyVar -- naughty var
+ -> TyVarSet -- skolems that would escape
+ -> TcM a
+naughtyQuantification orig_ty tv escapees
+ = do { orig_ty1 <- zonkTcType orig_ty -- in case it's not zonked
+
+ ; escapees' <- mapM zonkTcTyVarToTyVar $
+ nonDetEltsUniqSet escapees
+ -- we'll just be printing, so no harmful non-determinism
+
+ ; let fvs = tyCoVarsOfTypeWellScoped orig_ty1
+ env0 = tidyFreeTyCoVars emptyTidyEnv fvs
+ env = env0 `delTidyEnvList` escapees'
+ -- this avoids gratuitous renaming of the escaped
+ -- variables; very confusing to users!
+
+ orig_ty' = tidyType env orig_ty1
+ ppr_tidied = pprTyVars . map (tidyTyCoVarOcc env)
+ doc = pprWithExplicitKindsWhen True $
+ vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees'
+ , quotes $ ppr_tidied escapees'
+ , text "would escape" <+> itsOrTheir escapees' <+> text "scope"
+ ]
+ , sep [ text "if I tried to quantify"
+ , ppr_tidied [tv]
+ , text "in this type:"
+ ]
+ , nest 2 (pprTidiedType orig_ty')
+ , text "(Indeed, I sometimes struggle even printing this correctly,"
+ , text " due to its ill-scoped nature.)"
+ ]
+
+ ; failWithTcM (env, doc) }
diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs
new file mode 100644
index 0000000000..1f076e2101
--- /dev/null
+++ b/compiler/GHC/Tc/Utils/TcType.hs
@@ -0,0 +1,2489 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+-}
+
+{-# LANGUAGE CPP, ScopedTypeVariables, MultiWayIf, FlexibleContexts #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+
+-- | Types used in the typechecker}
+--
+-- This module provides the Type interface for front-end parts of the
+-- compiler. These parts
+--
+-- * treat "source types" as opaque:
+-- newtypes, and predicates are meaningful.
+-- * look through usage types
+--
+module GHC.Tc.Utils.TcType (
+ --------------------------------
+ -- Types
+ TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
+ TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet,
+ TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcTyCon,
+ KnotTied,
+
+ ExpType(..), InferResult(..), ExpSigmaType, ExpRhoType, mkCheckExpType,
+
+ SyntaxOpType(..), synKnownType, mkSynFunTys,
+
+ -- TcLevel
+ TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel,
+ strictlyDeeperThan, sameDepthAs,
+ tcTypeLevel, tcTyVarLevel, maxTcLevel,
+ promoteSkolem, promoteSkolemX, promoteSkolemsX,
+ --------------------------------
+ -- MetaDetails
+ TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv,
+ MetaDetails(Flexi, Indirect), MetaInfo(..),
+ isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy,
+ tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar, isTyConableTyVar,
+ isFskTyVar, isFmvTyVar, isFlattenTyVar,
+ isAmbiguousTyVar, metaTyVarRef, metaTyVarInfo,
+ isFlexi, isIndirect, isRuntimeUnkSkol,
+ metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe,
+ isTouchableMetaTyVar,
+ isFloatedTouchableMetaTyVar,
+ findDupTyVarTvs, mkTyVarNamePairs,
+
+ --------------------------------
+ -- Builders
+ mkPhiTy, mkInfSigmaTy, mkSpecSigmaTy, mkSigmaTy,
+ mkTcAppTy, mkTcAppTys, mkTcCastTy,
+
+ --------------------------------
+ -- Splitters
+ -- These are important because they do not look through newtypes
+ getTyVar,
+ tcSplitForAllTy_maybe,
+ tcSplitForAllTys, tcSplitForAllTysSameVis,
+ tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllVarBndrs,
+ tcSplitPhiTy, tcSplitPredFunTy_maybe,
+ tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN,
+ tcSplitFunTysN,
+ tcSplitTyConApp, tcSplitTyConApp_maybe,
+ tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs,
+ tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe,
+ tcRepGetNumAppTys,
+ tcGetCastedTyVar_maybe, tcGetTyVar_maybe, tcGetTyVar,
+ tcSplitSigmaTy, tcSplitNestedSigmaTys, tcDeepSplitSigmaTy_maybe,
+
+ ---------------------------------
+ -- Predicates.
+ -- Again, newtypes are opaque
+ eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX,
+ pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis,
+ isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy,
+ isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
+ isIntegerTy, isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred,
+ hasIPPred, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
+ isPredTy, isTyVarClassPred, isTyVarHead, isInsolubleOccursCheck,
+ checkValidClsArgs, hasTyVarHead,
+ isRigidTy, isAlmostFunctionFree,
+
+ ---------------------------------
+ -- Misc type manipulators
+
+ deNoteType,
+ orphNamesOfType, orphNamesOfCo,
+ orphNamesOfTypes, orphNamesOfCoCon,
+ getDFunTyKey, evVarPred,
+
+ ---------------------------------
+ -- Predicate types
+ mkMinimalBySCs, transSuperClasses,
+ pickQuantifiablePreds, pickCapturedPreds,
+ immSuperClasses, boxEqPred,
+ isImprovementPred,
+
+ -- * Finding type instances
+ tcTyFamInsts, tcTyFamInstsAndVis, tcTyConAppTyFamInstsAndVis, isTyFamFree,
+
+ -- * Finding "exact" (non-dead) type variables
+ exactTyCoVarsOfType, exactTyCoVarsOfTypes,
+ anyRewritableTyVar,
+
+ ---------------------------------
+ -- Foreign import and export
+ isFFIArgumentTy, -- :: DynFlags -> Safety -> Type -> Bool
+ isFFIImportResultTy, -- :: DynFlags -> Type -> Bool
+ isFFIExportResultTy, -- :: Type -> Bool
+ isFFIExternalTy, -- :: Type -> Bool
+ isFFIDynTy, -- :: Type -> Type -> Bool
+ isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool
+ isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool
+ isFFILabelTy, -- :: Type -> Bool
+ isFFITy, -- :: Type -> Bool
+ isFunPtrTy, -- :: Type -> Bool
+ tcSplitIOType_maybe, -- :: Type -> Maybe Type
+
+ --------------------------------
+ -- Reexported from Kind
+ Kind, tcTypeKind,
+ liftedTypeKind,
+ constraintKind,
+ isLiftedTypeKind, isUnliftedTypeKind, classifiesTypeWithValues,
+
+ --------------------------------
+ -- Reexported from Type
+ Type, PredType, ThetaType, TyCoBinder,
+ ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..),
+
+ mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, mkSpecForAllTys, mkTyCoInvForAllTy,
+ mkInvForAllTy, mkInvForAllTys,
+ mkVisFunTy, mkVisFunTys, mkInvisFunTy, mkInvisFunTys,
+ mkTyConApp, mkAppTy, mkAppTys,
+ mkTyConTy, mkTyVarTy, mkTyVarTys,
+ mkTyCoVarTy, mkTyCoVarTys,
+
+ isClassPred, isEqPrimPred, isIPPred, isEqPred, isEqPredClass,
+ mkClassPred,
+ tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy,
+ isRuntimeRepVar, isKindLevPoly,
+ isVisibleBinder, isInvisibleBinder,
+
+ -- Type substitutions
+ TCvSubst(..), -- Representation visible to a few friends
+ TvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst,
+ zipTvSubst,
+ mkTvSubstPrs, notElemTCvSubst, unionTCvSubst,
+ getTvSubstEnv, setTvSubstEnv, getTCvInScope, extendTCvInScope,
+ extendTCvInScopeList, extendTCvInScopeSet, extendTvSubstAndInScope,
+ Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr,
+ Type.extendTvSubst,
+ isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv,
+ Type.substTy, substTys, substTyWith, substTyWithCoVars,
+ substTyAddInScope,
+ substTyUnchecked, substTysUnchecked, substThetaUnchecked,
+ substTyWithUnchecked,
+ substCoUnchecked, substCoWithUnchecked,
+ substTheta,
+
+ isUnliftedType, -- Source types are always lifted
+ isUnboxedTupleType, -- Ditto
+ isPrimitiveType,
+
+ tcView, coreView,
+
+ tyCoVarsOfType, tyCoVarsOfTypes, closeOverKinds,
+ tyCoFVsOfType, tyCoFVsOfTypes,
+ tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, closeOverKindsDSet,
+ tyCoVarsOfTypeList, tyCoVarsOfTypesList,
+ noFreeVarsOfType,
+
+ --------------------------------
+ pprKind, pprParendKind, pprSigmaType,
+ pprType, pprParendType, pprTypeApp, pprTyThingCategory, tyThingCategory,
+ pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred,
+ pprTCvBndr, pprTCvBndrs,
+
+ TypeSize, sizeType, sizeTypes, scopedSort,
+
+ ---------------------------------
+ -- argument visibility
+ tcTyConVisibilities, isNextTyConArgVisible, isNextArgVisible
+
+ ) where
+
+#include "HsVersions.h"
+
+-- friends:
+import GhcPrelude
+
+import GHC.Core.TyCo.Rep
+import GHC.Core.TyCo.Subst ( mkTvSubst, substTyWithCoVars )
+import GHC.Core.TyCo.FVs
+import GHC.Core.TyCo.Ppr
+import GHC.Core.Class
+import GHC.Types.Var
+import GHC.Types.ForeignCall
+import GHC.Types.Var.Set
+import GHC.Core.Coercion
+import GHC.Core.Type as Type
+import GHC.Core.Predicate
+import GHC.Types.RepType
+import GHC.Core.TyCon
+
+-- others:
+import GHC.Driver.Session
+import GHC.Core.FVs
+import GHC.Types.Name as Name
+ -- We use this to make dictionaries for type literals.
+ -- Perhaps there's a better way to do this?
+import GHC.Types.Name.Set
+import GHC.Types.Var.Env
+import PrelNames
+import TysWiredIn( coercibleClass, eqClass, heqClass, unitTyCon, unitTyConKey
+ , listTyCon, constraintKind )
+import GHC.Types.Basic
+import Util
+import Maybes
+import ListSetOps ( getNth, findDupsEq )
+import Outputable
+import FastString
+import ErrUtils( Validity(..), MsgDoc, isValid )
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.List ( mapAccumL )
+-- import Data.Functor.Identity( Identity(..) )
+import Data.IORef
+import Data.List.NonEmpty( NonEmpty(..) )
+
+{-
+************************************************************************
+* *
+ Types
+* *
+************************************************************************
+
+The type checker divides the generic Type world into the
+following more structured beasts:
+
+sigma ::= forall tyvars. phi
+ -- A sigma type is a qualified type
+ --
+ -- Note that even if 'tyvars' is empty, theta
+ -- may not be: e.g. (?x::Int) => Int
+
+ -- Note that 'sigma' is in prenex form:
+ -- all the foralls are at the front.
+ -- A 'phi' type has no foralls to the right of
+ -- an arrow
+
+phi :: theta => rho
+
+rho ::= sigma -> rho
+ | tau
+
+-- A 'tau' type has no quantification anywhere
+-- Note that the args of a type constructor must be taus
+tau ::= tyvar
+ | tycon tau_1 .. tau_n
+ | tau_1 tau_2
+ | tau_1 -> tau_2
+
+-- In all cases, a (saturated) type synonym application is legal,
+-- provided it expands to the required form.
+
+Note [TcTyVars and TyVars in the typechecker]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The typechecker uses a lot of type variables with special properties,
+notably being a unification variable with a mutable reference. These
+use the 'TcTyVar' variant of Var.Var.
+
+Note, though, that a /bound/ type variable can (and probably should)
+be a TyVar. E.g
+ forall a. a -> a
+Here 'a' is really just a deBruijn-number; it certainly does not have
+a significant TcLevel (as every TcTyVar does). So a forall-bound type
+variable should be TyVars; and hence a TyVar can appear free in a TcType.
+
+The type checker and constraint solver can also encounter /free/ type
+variables that use the 'TyVar' variant of Var.Var, for a couple of
+reasons:
+
+ - When typechecking a class decl, say
+ class C (a :: k) where
+ foo :: T a -> Int
+ We have first kind-check the header; fix k and (a:k) to be
+ TyVars, bring 'k' and 'a' into scope, and kind check the
+ signature for 'foo'. In doing so we call solveEqualities to
+ solve any kind equalities in foo's signature. So the solver
+ may see free occurrences of 'k'.
+
+ See calls to tcExtendTyVarEnv for other places that ordinary
+ TyVars are bought into scope, and hence may show up in the types
+ and kinds generated by GHC.Tc.Gen.HsType.
+
+ - The pattern-match overlap checker calls the constraint solver,
+ long after TcTyVars have been zonked away
+
+It's convenient to simply treat these TyVars as skolem constants,
+which of course they are. We give them a level number of "outermost",
+so they behave as global constants. Specifically:
+
+* Var.tcTyVarDetails succeeds on a TyVar, returning
+ vanillaSkolemTv, as well as on a TcTyVar.
+
+* tcIsTcTyVar returns True for both TyVar and TcTyVar variants
+ of Var.Var. The "tc" prefix means "a type variable that can be
+ encountered by the typechecker".
+
+This is a bit of a change from an earlier era when we remoselessly
+insisted on real TcTyVars in the type checker. But that seems
+unnecessary (for skolems, TyVars are fine) and it's now very hard
+to guarantee, with the advent of kind equalities.
+
+Note [Coercion variables in free variable lists]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are several places in the GHC codebase where functions like
+tyCoVarsOfType, tyCoVarsOfCt, et al. are used to compute the free type
+variables of a type. The "Co" part of these functions' names shouldn't be
+dismissed, as it is entirely possible that they will include coercion variables
+in addition to type variables! As a result, there are some places in GHC.Tc.Utils.TcType
+where we must take care to check that a variable is a _type_ variable (using
+isTyVar) before calling tcTyVarDetails--a partial function that is not defined
+for coercion variables--on the variable. Failing to do so led to
+GHC #12785.
+-}
+
+-- See Note [TcTyVars and TyVars in the typechecker]
+type TcCoVar = CoVar -- Used only during type inference
+type TcType = Type -- A TcType can have mutable type variables
+type TcTyCoVar = Var -- Either a TcTyVar or a CoVar
+ -- Invariant on ForAllTy in TcTypes:
+ -- forall a. T
+ -- a cannot occur inside a MutTyVar in T; that is,
+ -- T is "flattened" before quantifying over a
+
+type TcTyVarBinder = TyVarBinder
+type TcTyCon = TyCon -- these can be the TcTyCon constructor
+
+-- These types do not have boxy type variables in them
+type TcPredType = PredType
+type TcThetaType = ThetaType
+type TcSigmaType = TcType
+type TcRhoType = TcType -- Note [TcRhoType]
+type TcTauType = TcType
+type TcKind = Kind
+type TcTyVarSet = TyVarSet
+type TcTyCoVarSet = TyCoVarSet
+type TcDTyVarSet = DTyVarSet
+type TcDTyCoVarSet = DTyCoVarSet
+
+{- *********************************************************************
+* *
+ ExpType: an "expected type" in the type checker
+* *
+********************************************************************* -}
+
+-- | An expected type to check against during type-checking.
+-- See Note [ExpType] in GHC.Tc.Utils.TcMType, where you'll also find manipulators.
+data ExpType = Check TcType
+ | Infer !InferResult
+
+data InferResult
+ = IR { ir_uniq :: Unique -- For debugging only
+
+ , ir_lvl :: TcLevel -- See Note [TcLevel of ExpType] in GHC.Tc.Utils.TcMType
+
+ , ir_inst :: Bool
+ -- True <=> deeply instantiate before returning
+ -- i.e. return a RhoType
+ -- False <=> do not instantiate before returning
+ -- i.e. return a SigmaType
+ -- See Note [Deep instantiation of InferResult] in GHC.Tc.Utils.Unify
+
+ , ir_ref :: IORef (Maybe TcType) }
+ -- The type that fills in this hole should be a Type,
+ -- that is, its kind should be (TYPE rr) for some rr
+
+type ExpSigmaType = ExpType
+type ExpRhoType = ExpType
+
+instance Outputable ExpType where
+ ppr (Check ty) = text "Check" <> braces (ppr ty)
+ ppr (Infer ir) = ppr ir
+
+instance Outputable InferResult where
+ ppr (IR { ir_uniq = u, ir_lvl = lvl
+ , ir_inst = inst })
+ = text "Infer" <> braces (ppr u <> comma <> ppr lvl <+> ppr inst)
+
+-- | Make an 'ExpType' suitable for checking.
+mkCheckExpType :: TcType -> ExpType
+mkCheckExpType = Check
+
+
+{- *********************************************************************
+* *
+ SyntaxOpType
+* *
+********************************************************************* -}
+
+-- | What to expect for an argument to a rebindable-syntax operator.
+-- Quite like 'Type', but allows for holes to be filled in by tcSyntaxOp.
+-- The callback called from tcSyntaxOp gets a list of types; the meaning
+-- of these types is determined by a left-to-right depth-first traversal
+-- of the 'SyntaxOpType' tree. So if you pass in
+--
+-- > SynAny `SynFun` (SynList `SynFun` SynType Int) `SynFun` SynAny
+--
+-- you'll get three types back: one for the first 'SynAny', the /element/
+-- type of the list, and one for the last 'SynAny'. You don't get anything
+-- for the 'SynType', because you've said positively that it should be an
+-- Int, and so it shall be.
+--
+-- This is defined here to avoid defining it in GHC.Tc.Gen.Expr boot file.
+data SyntaxOpType
+ = SynAny -- ^ Any type
+ | SynRho -- ^ A rho type, deeply skolemised or instantiated as appropriate
+ | SynList -- ^ A list type. You get back the element type of the list
+ | SynFun SyntaxOpType SyntaxOpType
+ -- ^ A function.
+ | SynType ExpType -- ^ A known type.
+infixr 0 `SynFun`
+
+-- | Like 'SynType' but accepts a regular TcType
+synKnownType :: TcType -> SyntaxOpType
+synKnownType = SynType . mkCheckExpType
+
+-- | Like 'mkFunTys' but for 'SyntaxOpType'
+mkSynFunTys :: [SyntaxOpType] -> ExpType -> SyntaxOpType
+mkSynFunTys arg_tys res_ty = foldr SynFun (SynType res_ty) arg_tys
+
+
+{-
+Note [TcRhoType]
+~~~~~~~~~~~~~~~~
+A TcRhoType has no foralls or contexts at the top, or to the right of an arrow
+ YES (forall a. a->a) -> Int
+ NO forall a. a -> Int
+ NO Eq a => a -> a
+ NO Int -> forall a. a -> Int
+
+
+************************************************************************
+* *
+ TyVarDetails, MetaDetails, MetaInfo
+* *
+************************************************************************
+
+TyVarDetails gives extra info about type variables, used during type
+checking. It's attached to mutable type variables only.
+It's knot-tied back to Var.hs. There is no reason in principle
+why Var.hs shouldn't actually have the definition, but it "belongs" here.
+
+Note [Signature skolems]
+~~~~~~~~~~~~~~~~~~~~~~~~
+A TyVarTv is a specialised variant of TauTv, with the following invariants:
+
+ * A TyVarTv can be unified only with a TyVar,
+ not with any other type
+
+ * Its MetaDetails, if filled in, will always be another TyVarTv
+ or a SkolemTv
+
+TyVarTvs are only distinguished to improve error messages.
+Consider this
+
+ data T (a:k1) = MkT (S a)
+ data S (b:k2) = MkS (T b)
+
+When doing kind inference on {S,T} we don't want *skolems* for k1,k2,
+because they end up unifying; we want those TyVarTvs again.
+
+
+Note [TyVars and TcTyVars during type checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The Var type has constructors TyVar and TcTyVar. They are used
+as follows:
+
+* TcTyVar: used /only/ during type checking. Should never appear
+ afterwards. May contain a mutable field, in the MetaTv case.
+
+* TyVar: is never seen by the constraint solver, except locally
+ inside a type like (forall a. [a] ->[a]), where 'a' is a TyVar.
+ We instantiate these with TcTyVars before exposing the type
+ to the constraint solver.
+
+I have swithered about the latter invariant, excluding TyVars from the
+constraint solver. It's not strictly essential, and indeed
+(historically but still there) Var.tcTyVarDetails returns
+vanillaSkolemTv for a TyVar.
+
+But ultimately I want to seeparate Type from TcType, and in that case
+we would need to enforce the separation.
+-}
+
+-- A TyVarDetails is inside a TyVar
+-- See Note [TyVars and TcTyVars]
+data TcTyVarDetails
+ = SkolemTv -- A skolem
+ TcLevel -- Level of the implication that binds it
+ -- See GHC.Tc.Utils.Unify Note [Deeper level on the left] for
+ -- how this level number is used
+ Bool -- True <=> this skolem type variable can be overlapped
+ -- when looking up instances
+ -- See Note [Binding when looking up instances] in GHC.Core.InstEnv
+
+ | RuntimeUnk -- Stands for an as-yet-unknown type in the GHCi
+ -- interactive context
+
+ | MetaTv { mtv_info :: MetaInfo
+ , mtv_ref :: IORef MetaDetails
+ , mtv_tclvl :: TcLevel } -- See Note [TcLevel and untouchable type variables]
+
+vanillaSkolemTv, superSkolemTv :: TcTyVarDetails
+-- See Note [Binding when looking up instances] in GHC.Core.InstEnv
+vanillaSkolemTv = SkolemTv topTcLevel False -- Might be instantiated
+superSkolemTv = SkolemTv topTcLevel True -- Treat this as a completely distinct type
+ -- The choice of level number here is a bit dodgy, but
+ -- topTcLevel works in the places that vanillaSkolemTv is used
+
+instance Outputable TcTyVarDetails where
+ ppr = pprTcTyVarDetails
+
+pprTcTyVarDetails :: TcTyVarDetails -> SDoc
+-- For debugging
+pprTcTyVarDetails (RuntimeUnk {}) = text "rt"
+pprTcTyVarDetails (SkolemTv lvl True) = text "ssk" <> colon <> ppr lvl
+pprTcTyVarDetails (SkolemTv lvl False) = text "sk" <> colon <> ppr lvl
+pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl })
+ = ppr info <> colon <> ppr tclvl
+
+-----------------------------
+data MetaDetails
+ = Flexi -- Flexi type variables unify to become Indirects
+ | Indirect TcType
+
+data MetaInfo
+ = TauTv -- This MetaTv is an ordinary unification variable
+ -- A TauTv is always filled in with a tau-type, which
+ -- never contains any ForAlls.
+
+ | TyVarTv -- A variant of TauTv, except that it should not be
+ -- unified with a type, only with a type variable
+ -- See Note [Signature skolems]
+
+ | FlatMetaTv -- A flatten meta-tyvar
+ -- It is a meta-tyvar, but it is always untouchable, with level 0
+ -- See Note [The flattening story] in GHC.Tc.Solver.Flatten
+
+ | FlatSkolTv -- A flatten skolem tyvar
+ -- Just like FlatMetaTv, but is completely "owned" by
+ -- its Given CFunEqCan.
+ -- It is filled in /only/ by unflattenGivens
+ -- See Note [The flattening story] in GHC.Tc.Solver.Flatten
+
+instance Outputable MetaDetails where
+ ppr Flexi = text "Flexi"
+ ppr (Indirect ty) = text "Indirect" <+> ppr ty
+
+instance Outputable MetaInfo where
+ ppr TauTv = text "tau"
+ ppr TyVarTv = text "tyv"
+ ppr FlatMetaTv = text "fmv"
+ ppr FlatSkolTv = text "fsk"
+
+{- *********************************************************************
+* *
+ Untouchable type variables
+* *
+********************************************************************* -}
+
+newtype TcLevel = TcLevel Int deriving( Eq, Ord )
+ -- See Note [TcLevel and untouchable type variables] for what this Int is
+ -- See also Note [TcLevel assignment]
+
+{-
+Note [TcLevel and untouchable type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Each unification variable (MetaTv)
+ and each Implication
+ has a level number (of type TcLevel)
+
+* INVARIANTS. In a tree of Implications,
+
+ (ImplicInv) The level number (ic_tclvl) of an Implication is
+ STRICTLY GREATER THAN that of its parent
+
+ (SkolInv) The level number of the skolems (ic_skols) of an
+ Implication is equal to the level of the implication
+ itself (ic_tclvl)
+
+ (GivenInv) The level number of a unification variable appearing
+ in the 'ic_given' of an implication I should be
+ STRICTLY LESS THAN the ic_tclvl of I
+
+ (WantedInv) The level number of a unification variable appearing
+ in the 'ic_wanted' of an implication I should be
+ LESS THAN OR EQUAL TO the ic_tclvl of I
+ See Note [WantedInv]
+
+* A unification variable is *touchable* if its level number
+ is EQUAL TO that of its immediate parent implication,
+ and it is a TauTv or TyVarTv (but /not/ FlatMetaTv or FlatSkolTv)
+
+Note [WantedInv]
+~~~~~~~~~~~~~~~~
+Why is WantedInv important? Consider this implication, where
+the constraint (C alpha[3]) disobeys WantedInv:
+
+ forall[2] a. blah => (C alpha[3])
+ (forall[3] b. alpha[3] ~ b)
+
+We can unify alpha:=b in the inner implication, because 'alpha' is
+touchable; but then 'b' has excaped its scope into the outer implication.
+
+Note [Skolem escape prevention]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We only unify touchable unification variables. Because of
+(WantedInv), there can be no occurrences of the variable further out,
+so the unification can't cause the skolems to escape. Example:
+ data T = forall a. MkT a (a->Int)
+ f x (MkT v f) = length [v,x]
+We decide (x::alpha), and generate an implication like
+ [1]forall a. (a ~ alpha[0])
+But we must not unify alpha:=a, because the skolem would escape.
+
+For the cases where we DO want to unify, we rely on floating the
+equality. Example (with same T)
+ g x (MkT v f) = x && True
+We decide (x::alpha), and generate an implication like
+ [1]forall a. (Bool ~ alpha[0])
+We do NOT unify directly, bur rather float out (if the constraint
+does not mention 'a') to get
+ (Bool ~ alpha[0]) /\ [1]forall a.()
+and NOW we can unify alpha.
+
+The same idea of only unifying touchables solves another problem.
+Suppose we had
+ (F Int ~ uf[0]) /\ [1](forall a. C a => F Int ~ beta[1])
+In this example, beta is touchable inside the implication. The
+first solveSimpleWanteds step leaves 'uf' un-unified. Then we move inside
+the implication where a new constraint
+ uf ~ beta
+emerges. If we (wrongly) spontaneously solved it to get uf := beta,
+the whole implication disappears but when we pop out again we are left with
+(F Int ~ uf) which will be unified by our final zonking stage and
+uf will get unified *once more* to (F Int).
+
+Note [TcLevel assignment]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+We arrange the TcLevels like this
+
+ 0 Top level
+ 1 First-level implication constraints
+ 2 Second-level implication constraints
+ ...etc...
+-}
+
+maxTcLevel :: TcLevel -> TcLevel -> TcLevel
+maxTcLevel (TcLevel a) (TcLevel b) = TcLevel (a `max` b)
+
+topTcLevel :: TcLevel
+-- See Note [TcLevel assignment]
+topTcLevel = TcLevel 0 -- 0 = outermost level
+
+isTopTcLevel :: TcLevel -> Bool
+isTopTcLevel (TcLevel 0) = True
+isTopTcLevel _ = False
+
+pushTcLevel :: TcLevel -> TcLevel
+-- See Note [TcLevel assignment]
+pushTcLevel (TcLevel us) = TcLevel (us + 1)
+
+strictlyDeeperThan :: TcLevel -> TcLevel -> Bool
+strictlyDeeperThan (TcLevel tv_tclvl) (TcLevel ctxt_tclvl)
+ = tv_tclvl > ctxt_tclvl
+
+sameDepthAs :: TcLevel -> TcLevel -> Bool
+sameDepthAs (TcLevel ctxt_tclvl) (TcLevel tv_tclvl)
+ = ctxt_tclvl == tv_tclvl -- NB: invariant ctxt_tclvl >= tv_tclvl
+ -- So <= would be equivalent
+
+checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool
+-- Checks (WantedInv) from Note [TcLevel and untouchable type variables]
+checkTcLevelInvariant (TcLevel ctxt_tclvl) (TcLevel tv_tclvl)
+ = ctxt_tclvl >= tv_tclvl
+
+-- Returns topTcLevel for non-TcTyVars
+tcTyVarLevel :: TcTyVar -> TcLevel
+tcTyVarLevel tv
+ = case tcTyVarDetails tv of
+ MetaTv { mtv_tclvl = tv_lvl } -> tv_lvl
+ SkolemTv tv_lvl _ -> tv_lvl
+ RuntimeUnk -> topTcLevel
+
+
+tcTypeLevel :: TcType -> TcLevel
+-- Max level of any free var of the type
+tcTypeLevel ty
+ = foldDVarSet add topTcLevel (tyCoVarsOfTypeDSet ty)
+ where
+ add v lvl
+ | isTcTyVar v = lvl `maxTcLevel` tcTyVarLevel v
+ | otherwise = lvl
+
+instance Outputable TcLevel where
+ ppr (TcLevel us) = ppr us
+
+promoteSkolem :: TcLevel -> TcTyVar -> TcTyVar
+promoteSkolem tclvl skol
+ | tclvl < tcTyVarLevel skol
+ = ASSERT( isTcTyVar skol && isSkolemTyVar skol )
+ setTcTyVarDetails skol (SkolemTv tclvl (isOverlappableTyVar skol))
+
+ | otherwise
+ = skol
+
+-- | Change the TcLevel in a skolem, extending a substitution
+promoteSkolemX :: TcLevel -> TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar)
+promoteSkolemX tclvl subst skol
+ = ASSERT( isTcTyVar skol && isSkolemTyVar skol )
+ (new_subst, new_skol)
+ where
+ new_skol
+ | tclvl < tcTyVarLevel skol
+ = setTcTyVarDetails (updateTyVarKind (substTy subst) skol)
+ (SkolemTv tclvl (isOverlappableTyVar skol))
+ | otherwise
+ = updateTyVarKind (substTy subst) skol
+ new_subst = extendTvSubstWithClone subst skol new_skol
+
+promoteSkolemsX :: TcLevel -> TCvSubst -> [TcTyVar] -> (TCvSubst, [TcTyVar])
+promoteSkolemsX tclvl = mapAccumL (promoteSkolemX tclvl)
+
+{- *********************************************************************
+* *
+ Finding type family instances
+* *
+************************************************************************
+-}
+
+-- | Finds outermost type-family applications occurring in a type,
+-- after expanding synonyms. In the list (F, tys) that is returned
+-- we guarantee that tys matches F's arity. For example, given
+-- type family F a :: * -> * (arity 1)
+-- calling tcTyFamInsts on (Maybe (F Int Bool) will return
+-- (F, [Int]), not (F, [Int,Bool])
+--
+-- This is important for its use in deciding termination of type
+-- instances (see #11581). E.g.
+-- type instance G [Int] = ...(F Int <big type>)...
+-- we don't need to take <big type> into account when asking if
+-- the calls on the RHS are smaller than the LHS
+tcTyFamInsts :: Type -> [(TyCon, [Type])]
+tcTyFamInsts = map (\(_,b,c) -> (b,c)) . tcTyFamInstsAndVis
+
+-- | Like 'tcTyFamInsts', except that the output records whether the
+-- type family and its arguments occur as an /invisible/ argument in
+-- some type application. This information is useful because it helps GHC know
+-- when to turn on @-fprint-explicit-kinds@ during error reporting so that
+-- users can actually see the type family being mentioned.
+--
+-- As an example, consider:
+--
+-- @
+-- class C a
+-- data T (a :: k)
+-- type family F a :: k
+-- instance C (T @(F Int) (F Bool))
+-- @
+--
+-- There are two occurrences of the type family `F` in that `C` instance, so
+-- @'tcTyFamInstsAndVis' (C (T \@(F Int) (F Bool)))@ will return:
+--
+-- @
+-- [ ('True', F, [Int])
+-- , ('False', F, [Bool]) ]
+-- @
+--
+-- @F Int@ is paired with 'True' since it appears as an /invisible/ argument
+-- to @C@, whereas @F Bool@ is paired with 'False' since it appears an a
+-- /visible/ argument to @C@.
+--
+-- See also @Note [Kind arguments in error messages]@ in "GHC.Tc.Errors".
+tcTyFamInstsAndVis :: Type -> [(Bool, TyCon, [Type])]
+tcTyFamInstsAndVis = tcTyFamInstsAndVisX False
+
+tcTyFamInstsAndVisX
+ :: Bool -- ^ Is this an invisible argument to some type application?
+ -> Type -> [(Bool, TyCon, [Type])]
+tcTyFamInstsAndVisX = go
+ where
+ go is_invis_arg ty
+ | Just exp_ty <- tcView ty = go is_invis_arg exp_ty
+ go _ (TyVarTy _) = []
+ go is_invis_arg (TyConApp tc tys)
+ | isTypeFamilyTyCon tc
+ = [(is_invis_arg, tc, take (tyConArity tc) tys)]
+ | otherwise
+ = tcTyConAppTyFamInstsAndVisX is_invis_arg tc tys
+ go _ (LitTy {}) = []
+ go is_invis_arg (ForAllTy bndr ty) = go is_invis_arg (binderType bndr)
+ ++ go is_invis_arg ty
+ go is_invis_arg (FunTy _ ty1 ty2) = go is_invis_arg ty1
+ ++ go is_invis_arg ty2
+ go is_invis_arg ty@(AppTy _ _) =
+ let (ty_head, ty_args) = splitAppTys ty
+ ty_arg_flags = appTyArgFlags ty_head ty_args
+ in go is_invis_arg ty_head
+ ++ concat (zipWith (\flag -> go (isInvisibleArgFlag flag))
+ ty_arg_flags ty_args)
+ go is_invis_arg (CastTy ty _) = go is_invis_arg ty
+ go _ (CoercionTy _) = [] -- don't count tyfams in coercions,
+ -- as they never get normalized,
+ -- anyway
+
+-- | In an application of a 'TyCon' to some arguments, find the outermost
+-- occurrences of type family applications within the arguments. This function
+-- will not consider the 'TyCon' itself when checking for type family
+-- applications.
+--
+-- See 'tcTyFamInstsAndVis' for more details on how this works (as this
+-- function is called inside of 'tcTyFamInstsAndVis').
+tcTyConAppTyFamInstsAndVis :: TyCon -> [Type] -> [(Bool, TyCon, [Type])]
+tcTyConAppTyFamInstsAndVis = tcTyConAppTyFamInstsAndVisX False
+
+tcTyConAppTyFamInstsAndVisX
+ :: Bool -- ^ Is this an invisible argument to some type application?
+ -> TyCon -> [Type] -> [(Bool, TyCon, [Type])]
+tcTyConAppTyFamInstsAndVisX is_invis_arg tc tys =
+ let (invis_tys, vis_tys) = partitionInvisibleTypes tc tys
+ in concat $ map (tcTyFamInstsAndVisX True) invis_tys
+ ++ map (tcTyFamInstsAndVisX is_invis_arg) vis_tys
+
+isTyFamFree :: Type -> Bool
+-- ^ Check that a type does not contain any type family applications.
+isTyFamFree = null . tcTyFamInsts
+
+anyRewritableTyVar :: Bool -- Ignore casts and coercions
+ -> EqRel -- Ambient role
+ -> (EqRel -> TcTyVar -> Bool)
+ -> TcType -> Bool
+-- (anyRewritableTyVar ignore_cos pred ty) returns True
+-- if the 'pred' returns True of any free TyVar in 'ty'
+-- Do not look inside casts and coercions if 'ignore_cos' is True
+-- See Note [anyRewritableTyVar must be role-aware]
+anyRewritableTyVar ignore_cos role pred ty
+ = go role emptyVarSet ty
+ where
+ -- NB: No need to expand synonyms, because we can find
+ -- all free variables of a synonym by looking at its
+ -- arguments
+
+ go_tv rl bvs tv | tv `elemVarSet` bvs = False
+ | otherwise = pred rl tv
+
+ go rl bvs (TyVarTy tv) = go_tv rl bvs tv
+ go _ _ (LitTy {}) = False
+ go rl bvs (TyConApp tc tys) = go_tc rl bvs tc tys
+ go rl bvs (AppTy fun arg) = go rl bvs fun || go NomEq bvs arg
+ go rl bvs (FunTy _ arg res) = go NomEq bvs arg_rep || go NomEq bvs res_rep ||
+ go rl bvs arg || go rl bvs res
+ where arg_rep = getRuntimeRep arg -- forgetting these causes #17024
+ res_rep = getRuntimeRep res
+ go rl bvs (ForAllTy tv ty) = go rl (bvs `extendVarSet` binderVar tv) ty
+ go rl bvs (CastTy ty co) = go rl bvs ty || go_co rl bvs co
+ go rl bvs (CoercionTy co) = go_co rl bvs co -- ToDo: check
+
+ go_tc NomEq bvs _ tys = any (go NomEq bvs) tys
+ go_tc ReprEq bvs tc tys = any (go_arg bvs)
+ (tyConRolesRepresentational tc `zip` tys)
+
+ go_arg bvs (Nominal, ty) = go NomEq bvs ty
+ go_arg bvs (Representational, ty) = go ReprEq bvs ty
+ go_arg _ (Phantom, _) = False -- We never rewrite with phantoms
+
+ go_co rl bvs co
+ | ignore_cos = False
+ | otherwise = anyVarSet (go_tv rl bvs) (tyCoVarsOfCo co)
+ -- We don't have an equivalent of anyRewritableTyVar for coercions
+ -- (at least not yet) so take the free vars and test them
+
+{- Note [anyRewritableTyVar must be role-aware]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+anyRewritableTyVar is used during kick-out from the inert set,
+to decide if, given a new equality (a ~ ty), we should kick out
+a constraint C. Rather than gather free variables and see if 'a'
+is among them, we instead pass in a predicate; this is just efficiency.
+
+Moreover, consider
+ work item: [G] a ~R f b
+ inert item: [G] b ~R f a
+We use anyRewritableTyVar to decide whether to kick out the inert item,
+on the grounds that the work item might rewrite it. Well, 'a' is certainly
+free in [G] b ~R f a. But because the role of a type variable ('f' in
+this case) is nominal, the work item can't actually rewrite the inert item.
+Moreover, if we were to kick out the inert item the exact same situation
+would re-occur and we end up with an infinite loop in which each kicks
+out the other (#14363).
+-}
+
+{- *********************************************************************
+* *
+ The "exact" free variables of a type
+* *
+********************************************************************* -}
+
+{- Note [Silly type synonym]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ type T a = Int
+What are the free tyvars of (T x)? Empty, of course!
+
+exactTyCoVarsOfType is used by the type checker to figure out exactly
+which type variables are mentioned in a type. It only matters
+occasionally -- see the calls to exactTyCoVarsOfType.
+
+We place this function here in GHC.Tc.Utils.TcType, not in GHC.Core.TyCo.FVs,
+because we want to "see" tcView (efficiency issue only).
+-}
+
+exactTyCoVarsOfType :: Type -> TyCoVarSet
+exactTyCoVarsOfTypes :: [Type] -> TyCoVarSet
+-- Find the free type variables (of any kind)
+-- but *expand* type synonyms. See Note [Silly type synonym] above.
+
+exactTyCoVarsOfType ty = runTyCoVars (exact_ty ty)
+exactTyCoVarsOfTypes tys = runTyCoVars (exact_tys tys)
+
+exact_ty :: Type -> Endo TyCoVarSet
+exact_tys :: [Type] -> Endo TyCoVarSet
+(exact_ty, exact_tys, _, _) = foldTyCo exactTcvFolder emptyVarSet
+
+exactTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet)
+exactTcvFolder = deepTcvFolder { tcf_view = tcView }
+ -- This is the key line
+
+{-
+************************************************************************
+* *
+ Predicates
+* *
+************************************************************************
+-}
+
+tcIsTcTyVar :: TcTyVar -> Bool
+-- See Note [TcTyVars and TyVars in the typechecker]
+tcIsTcTyVar tv = isTyVar tv
+
+isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool
+isTouchableMetaTyVar ctxt_tclvl tv
+ | isTyVar tv -- See Note [Coercion variables in free variable lists]
+ , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv
+ , not (isFlattenInfo info)
+ = ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl,
+ ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl )
+ tv_tclvl `sameDepthAs` ctxt_tclvl
+
+ | otherwise = False
+
+isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool
+isFloatedTouchableMetaTyVar ctxt_tclvl tv
+ | isTyVar tv -- See Note [Coercion variables in free variable lists]
+ , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv
+ , not (isFlattenInfo info)
+ = tv_tclvl `strictlyDeeperThan` ctxt_tclvl
+
+ | otherwise = False
+
+isImmutableTyVar :: TyVar -> Bool
+isImmutableTyVar tv = isSkolemTyVar tv
+
+isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,
+ isMetaTyVar, isAmbiguousTyVar,
+ isFmvTyVar, isFskTyVar, isFlattenTyVar :: TcTyVar -> Bool
+
+isTyConableTyVar tv
+ -- True of a meta-type variable that can be filled in
+ -- with a type constructor application; in particular,
+ -- not a TyVarTv
+ | isTyVar tv -- See Note [Coercion variables in free variable lists]
+ = case tcTyVarDetails tv of
+ MetaTv { mtv_info = TyVarTv } -> False
+ _ -> True
+ | otherwise = True
+
+isFmvTyVar tv
+ = ASSERT2( tcIsTcTyVar tv, ppr tv )
+ case tcTyVarDetails tv of
+ MetaTv { mtv_info = FlatMetaTv } -> True
+ _ -> False
+
+isFskTyVar tv
+ = ASSERT2( tcIsTcTyVar tv, ppr tv )
+ case tcTyVarDetails tv of
+ MetaTv { mtv_info = FlatSkolTv } -> True
+ _ -> False
+
+-- | True of both given and wanted flatten-skolems (fmv and fsk)
+isFlattenTyVar tv
+ = ASSERT2( tcIsTcTyVar tv, ppr tv )
+ case tcTyVarDetails tv of
+ MetaTv { mtv_info = info } -> isFlattenInfo info
+ _ -> False
+
+isSkolemTyVar tv
+ = ASSERT2( tcIsTcTyVar tv, ppr tv )
+ case tcTyVarDetails tv of
+ MetaTv {} -> False
+ _other -> True
+
+isOverlappableTyVar tv
+ | isTyVar tv -- See Note [Coercion variables in free variable lists]
+ = case tcTyVarDetails tv of
+ SkolemTv _ overlappable -> overlappable
+ _ -> False
+ | otherwise = False
+
+isMetaTyVar tv
+ | isTyVar tv -- See Note [Coercion variables in free variable lists]
+ = case tcTyVarDetails tv of
+ MetaTv {} -> True
+ _ -> False
+ | otherwise = False
+
+-- isAmbiguousTyVar is used only when reporting type errors
+-- It picks out variables that are unbound, namely meta
+-- type variables and the RuntimUnk variables created by
+-- GHC.Runtime.Heap.Inspect.zonkRTTIType. These are "ambiguous" in
+-- the sense that they stand for an as-yet-unknown type
+isAmbiguousTyVar tv
+ | isTyVar tv -- See Note [Coercion variables in free variable lists]
+ = case tcTyVarDetails tv of
+ MetaTv {} -> True
+ RuntimeUnk {} -> True
+ _ -> False
+ | otherwise = False
+
+isMetaTyVarTy :: TcType -> Bool
+isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv
+isMetaTyVarTy _ = False
+
+metaTyVarInfo :: TcTyVar -> MetaInfo
+metaTyVarInfo tv
+ = case tcTyVarDetails tv of
+ MetaTv { mtv_info = info } -> info
+ _ -> pprPanic "metaTyVarInfo" (ppr tv)
+
+isFlattenInfo :: MetaInfo -> Bool
+isFlattenInfo FlatMetaTv = True
+isFlattenInfo FlatSkolTv = True
+isFlattenInfo _ = False
+
+metaTyVarTcLevel :: TcTyVar -> TcLevel
+metaTyVarTcLevel tv
+ = case tcTyVarDetails tv of
+ MetaTv { mtv_tclvl = tclvl } -> tclvl
+ _ -> pprPanic "metaTyVarTcLevel" (ppr tv)
+
+metaTyVarTcLevel_maybe :: TcTyVar -> Maybe TcLevel
+metaTyVarTcLevel_maybe tv
+ = case tcTyVarDetails tv of
+ MetaTv { mtv_tclvl = tclvl } -> Just tclvl
+ _ -> Nothing
+
+metaTyVarRef :: TyVar -> IORef MetaDetails
+metaTyVarRef tv
+ = case tcTyVarDetails tv of
+ MetaTv { mtv_ref = ref } -> ref
+ _ -> pprPanic "metaTyVarRef" (ppr tv)
+
+setMetaTyVarTcLevel :: TcTyVar -> TcLevel -> TcTyVar
+setMetaTyVarTcLevel tv tclvl
+ = case tcTyVarDetails tv of
+ details@(MetaTv {}) -> setTcTyVarDetails tv (details { mtv_tclvl = tclvl })
+ _ -> pprPanic "metaTyVarTcLevel" (ppr tv)
+
+isTyVarTyVar :: Var -> Bool
+isTyVarTyVar tv
+ = case tcTyVarDetails tv of
+ MetaTv { mtv_info = TyVarTv } -> True
+ _ -> False
+
+isFlexi, isIndirect :: MetaDetails -> Bool
+isFlexi Flexi = True
+isFlexi _ = False
+
+isIndirect (Indirect _) = True
+isIndirect _ = False
+
+isRuntimeUnkSkol :: TyVar -> Bool
+-- Called only in GHC.Tc.Errors; see Note [Runtime skolems] there
+isRuntimeUnkSkol x
+ | RuntimeUnk <- tcTyVarDetails x = True
+ | otherwise = False
+
+mkTyVarNamePairs :: [TyVar] -> [(Name,TyVar)]
+-- Just pair each TyVar with its own name
+mkTyVarNamePairs tvs = [(tyVarName tv, tv) | tv <- tvs]
+
+findDupTyVarTvs :: [(Name,TcTyVar)] -> [(Name,Name)]
+-- If we have [...(x1,tv)...(x2,tv)...]
+-- return (x1,x2) in the result list
+findDupTyVarTvs prs
+ = concatMap mk_result_prs $
+ findDupsEq eq_snd prs
+ where
+ eq_snd (_,tv1) (_,tv2) = tv1 == tv2
+ mk_result_prs ((n1,_) :| xs) = map (\(n2,_) -> (n1,n2)) xs
+
+{-
+************************************************************************
+* *
+\subsection{Tau, sigma and rho}
+* *
+************************************************************************
+-}
+
+mkSigmaTy :: [TyCoVarBinder] -> [PredType] -> Type -> Type
+mkSigmaTy bndrs theta tau = mkForAllTys bndrs (mkPhiTy theta tau)
+
+-- | Make a sigma ty where all type variables are 'Inferred'. That is,
+-- they cannot be used with visible type application.
+mkInfSigmaTy :: [TyCoVar] -> [PredType] -> Type -> Type
+mkInfSigmaTy tyvars theta ty = mkSigmaTy (mkTyCoVarBinders Inferred tyvars) theta ty
+
+-- | Make a sigma ty where all type variables are "specified". That is,
+-- they can be used with visible type application
+mkSpecSigmaTy :: [TyVar] -> [PredType] -> Type -> Type
+mkSpecSigmaTy tyvars preds ty = mkSigmaTy (mkTyCoVarBinders Specified tyvars) preds ty
+
+mkPhiTy :: [PredType] -> Type -> Type
+mkPhiTy = mkInvisFunTys
+
+---------------
+getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
+ -- construct a dictionary function name
+getDFunTyKey ty | Just ty' <- coreView ty = getDFunTyKey ty'
+getDFunTyKey (TyVarTy tv) = getOccName tv
+getDFunTyKey (TyConApp tc _) = getOccName tc
+getDFunTyKey (LitTy x) = getDFunTyLitKey x
+getDFunTyKey (AppTy fun _) = getDFunTyKey fun
+getDFunTyKey (FunTy {}) = getOccName funTyCon
+getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
+getDFunTyKey (CastTy ty _) = getDFunTyKey ty
+getDFunTyKey t@(CoercionTy _) = pprPanic "getDFunTyKey" (ppr t)
+
+getDFunTyLitKey :: TyLit -> OccName
+getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n)
+getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n) -- hm
+
+{- *********************************************************************
+* *
+ Building types
+* *
+********************************************************************* -}
+
+-- ToDo: I think we need Tc versions of these
+-- Reason: mkCastTy checks isReflexiveCastTy, which checks
+-- for equality; and that has a different answer
+-- depending on whether or not Type = Constraint
+
+mkTcAppTys :: Type -> [Type] -> Type
+mkTcAppTys = mkAppTys
+
+mkTcAppTy :: Type -> Type -> Type
+mkTcAppTy = mkAppTy
+
+mkTcCastTy :: Type -> Coercion -> Type
+mkTcCastTy = mkCastTy -- Do we need a tc version of mkCastTy?
+
+{-
+************************************************************************
+* *
+\subsection{Expanding and splitting}
+* *
+************************************************************************
+
+These tcSplit functions are like their non-Tc analogues, but
+ *) they do not look through newtypes
+
+However, they are non-monadic and do not follow through mutable type
+variables. It's up to you to make sure this doesn't matter.
+-}
+
+-- | Splits a forall type into a list of 'TyBinder's and the inner type.
+-- Always succeeds, even if it returns an empty list.
+tcSplitPiTys :: Type -> ([TyBinder], Type)
+tcSplitPiTys ty
+ = ASSERT( all isTyBinder (fst sty) ) sty
+ where sty = splitPiTys ty
+
+-- | Splits a type into a TyBinder and a body, if possible. Panics otherwise
+tcSplitPiTy_maybe :: Type -> Maybe (TyBinder, Type)
+tcSplitPiTy_maybe ty
+ = ASSERT( isMaybeTyBinder sty ) sty
+ where
+ sty = splitPiTy_maybe ty
+ isMaybeTyBinder (Just (t,_)) = isTyBinder t
+ isMaybeTyBinder _ = True
+
+tcSplitForAllTy_maybe :: Type -> Maybe (TyVarBinder, Type)
+tcSplitForAllTy_maybe ty | Just ty' <- tcView ty = tcSplitForAllTy_maybe ty'
+tcSplitForAllTy_maybe (ForAllTy tv ty) = ASSERT( isTyVarBinder tv ) Just (tv, ty)
+tcSplitForAllTy_maybe _ = Nothing
+
+-- | Like 'tcSplitPiTys', but splits off only named binders,
+-- returning just the tycovars.
+tcSplitForAllTys :: Type -> ([TyVar], Type)
+tcSplitForAllTys ty
+ = ASSERT( all isTyVar (fst sty) ) sty
+ where sty = splitForAllTys ty
+
+-- | Like 'tcSplitForAllTys', but only splits a 'ForAllTy' if
+-- @'sameVis' argf supplied_argf@ is 'True', where @argf@ is the visibility
+-- of the @ForAllTy@'s binder and @supplied_argf@ is the visibility provided
+-- as an argument to this function.
+tcSplitForAllTysSameVis :: ArgFlag -> Type -> ([TyVar], Type)
+tcSplitForAllTysSameVis supplied_argf ty = ASSERT( all isTyVar (fst sty) ) sty
+ where sty = splitForAllTysSameVis supplied_argf ty
+
+-- | Like 'tcSplitForAllTys', but splits off only named binders.
+tcSplitForAllVarBndrs :: Type -> ([TyVarBinder], Type)
+tcSplitForAllVarBndrs ty = ASSERT( all isTyVarBinder (fst sty)) sty
+ where sty = splitForAllVarBndrs ty
+
+-- | Is this a ForAllTy with a named binder?
+tcIsForAllTy :: Type -> Bool
+tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty'
+tcIsForAllTy (ForAllTy {}) = True
+tcIsForAllTy _ = False
+
+tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type)
+-- Split off the first predicate argument from a type
+tcSplitPredFunTy_maybe ty
+ | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty'
+tcSplitPredFunTy_maybe (FunTy { ft_af = InvisArg
+ , ft_arg = arg, ft_res = res })
+ = Just (arg, res)
+tcSplitPredFunTy_maybe _
+ = Nothing
+
+tcSplitPhiTy :: Type -> (ThetaType, Type)
+tcSplitPhiTy ty
+ = split ty []
+ where
+ split ty ts
+ = case tcSplitPredFunTy_maybe ty of
+ Just (pred, ty) -> split ty (pred:ts)
+ Nothing -> (reverse ts, ty)
+
+-- | Split a sigma type into its parts.
+tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)
+tcSplitSigmaTy ty = case tcSplitForAllTys ty of
+ (tvs, rho) -> case tcSplitPhiTy rho of
+ (theta, tau) -> (tvs, theta, tau)
+
+-- | Split a sigma type into its parts, going underneath as many @ForAllTy@s
+-- as possible. For example, given this type synonym:
+--
+-- @
+-- type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t
+-- @
+--
+-- if you called @tcSplitSigmaTy@ on this type:
+--
+-- @
+-- forall s t a b. Each s t a b => Traversal s t a b
+-- @
+--
+-- then it would return @([s,t,a,b], [Each s t a b], Traversal s t a b)@. But
+-- if you instead called @tcSplitNestedSigmaTys@ on the type, it would return
+-- @([s,t,a,b,f], [Each s t a b, Applicative f], (a -> f b) -> s -> f t)@.
+tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type)
+-- NB: This is basically a pure version of deeplyInstantiate (from Inst) that
+-- doesn't compute an HsWrapper.
+tcSplitNestedSigmaTys ty
+ -- If there's a forall, split it apart and try splitting the rho type
+ -- underneath it.
+ | Just (arg_tys, tvs1, theta1, rho1) <- tcDeepSplitSigmaTy_maybe ty
+ = let (tvs2, theta2, rho2) = tcSplitNestedSigmaTys rho1
+ in (tvs1 ++ tvs2, theta1 ++ theta2, mkVisFunTys arg_tys rho2)
+ -- If there's no forall, we're done.
+ | otherwise = ([], [], ty)
+
+-----------------------
+tcDeepSplitSigmaTy_maybe
+ :: TcSigmaType -> Maybe ([TcType], [TyVar], ThetaType, TcSigmaType)
+-- Looks for a *non-trivial* quantified type, under zero or more function arrows
+-- By "non-trivial" we mean either tyvars or constraints are non-empty
+
+tcDeepSplitSigmaTy_maybe ty
+ | Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty
+ , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty
+ = Just (arg_ty:arg_tys, tvs, theta, rho)
+
+ | (tvs, theta, rho) <- tcSplitSigmaTy ty
+ , not (null tvs && null theta)
+ = Just ([], tvs, theta, rho)
+
+ | otherwise = Nothing
+
+-----------------------
+tcTyConAppTyCon :: Type -> TyCon
+tcTyConAppTyCon ty
+ = case tcTyConAppTyCon_maybe ty of
+ Just tc -> tc
+ Nothing -> pprPanic "tcTyConAppTyCon" (pprType ty)
+
+-- | Like 'tcRepSplitTyConApp_maybe', but only returns the 'TyCon'.
+tcTyConAppTyCon_maybe :: Type -> Maybe TyCon
+tcTyConAppTyCon_maybe ty
+ | Just ty' <- tcView ty = tcTyConAppTyCon_maybe ty'
+tcTyConAppTyCon_maybe (TyConApp tc _)
+ = Just tc
+tcTyConAppTyCon_maybe (FunTy { ft_af = VisArg })
+ = Just funTyCon -- (=>) is /not/ a TyCon in its own right
+ -- C.f. tcRepSplitAppTy_maybe
+tcTyConAppTyCon_maybe _
+ = Nothing
+
+tcTyConAppArgs :: Type -> [Type]
+tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of
+ Just (_, args) -> args
+ Nothing -> pprPanic "tcTyConAppArgs" (pprType ty)
+
+tcSplitTyConApp :: Type -> (TyCon, [Type])
+tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
+ Just stuff -> stuff
+ Nothing -> pprPanic "tcSplitTyConApp" (pprType ty)
+
+-----------------------
+tcSplitFunTys :: Type -> ([Type], Type)
+tcSplitFunTys ty = case tcSplitFunTy_maybe ty of
+ Nothing -> ([], ty)
+ Just (arg,res) -> (arg:args, res')
+ where
+ (args,res') = tcSplitFunTys res
+
+tcSplitFunTy_maybe :: Type -> Maybe (Type, Type)
+tcSplitFunTy_maybe ty
+ | Just ty' <- tcView ty = tcSplitFunTy_maybe ty'
+tcSplitFunTy_maybe (FunTy { ft_af = af, ft_arg = arg, ft_res = res })
+ | VisArg <- af = Just (arg, res)
+tcSplitFunTy_maybe _ = Nothing
+ -- Note the VisArg guard
+ -- Consider (?x::Int) => Bool
+ -- We don't want to treat this as a function type!
+ -- A concrete example is test tc230:
+ -- f :: () -> (?p :: ()) => () -> ()
+ --
+ -- g = f () ()
+
+tcSplitFunTysN :: Arity -- n: Number of desired args
+ -> TcRhoType
+ -> Either Arity -- Number of missing arrows
+ ([TcSigmaType], -- Arg types (always N types)
+ TcSigmaType) -- The rest of the type
+-- ^ Split off exactly the specified number argument types
+-- Returns
+-- (Left m) if there are 'm' missing arrows in the type
+-- (Right (tys,res)) if the type looks like t1 -> ... -> tn -> res
+tcSplitFunTysN n ty
+ | n == 0
+ = Right ([], ty)
+ | Just (arg,res) <- tcSplitFunTy_maybe ty
+ = case tcSplitFunTysN (n-1) res of
+ Left m -> Left m
+ Right (args,body) -> Right (arg:args, body)
+ | otherwise
+ = Left n
+
+tcSplitFunTy :: Type -> (Type, Type)
+tcSplitFunTy ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty)
+
+tcFunArgTy :: Type -> Type
+tcFunArgTy ty = fst (tcSplitFunTy ty)
+
+tcFunResultTy :: Type -> Type
+tcFunResultTy ty = snd (tcSplitFunTy ty)
+
+-- | Strips off n *visible* arguments and returns the resulting type
+tcFunResultTyN :: HasDebugCallStack => Arity -> Type -> Type
+tcFunResultTyN n ty
+ | Right (_, res_ty) <- tcSplitFunTysN n ty
+ = res_ty
+ | otherwise
+ = pprPanic "tcFunResultTyN" (ppr n <+> ppr ty)
+
+-----------------------
+tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
+tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty'
+tcSplitAppTy_maybe ty = tcRepSplitAppTy_maybe ty
+
+tcSplitAppTy :: Type -> (Type, Type)
+tcSplitAppTy ty = case tcSplitAppTy_maybe ty of
+ Just stuff -> stuff
+ Nothing -> pprPanic "tcSplitAppTy" (pprType ty)
+
+tcSplitAppTys :: Type -> (Type, [Type])
+tcSplitAppTys ty
+ = go ty []
+ where
+ go ty args = case tcSplitAppTy_maybe ty of
+ Just (ty', arg) -> go ty' (arg:args)
+ Nothing -> (ty,args)
+
+-- | Returns the number of arguments in the given type, without
+-- looking through synonyms. This is used only for error reporting.
+-- We don't look through synonyms because of #11313.
+tcRepGetNumAppTys :: Type -> Arity
+tcRepGetNumAppTys = length . snd . repSplitAppTys
+
+-----------------------
+-- | If the type is a tyvar, possibly under a cast, returns it, along
+-- with the coercion. Thus, the co is :: kind tv ~N kind type
+tcGetCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN)
+tcGetCastedTyVar_maybe ty | Just ty' <- tcView ty = tcGetCastedTyVar_maybe ty'
+tcGetCastedTyVar_maybe (CastTy (TyVarTy tv) co) = Just (tv, co)
+tcGetCastedTyVar_maybe (TyVarTy tv) = Just (tv, mkNomReflCo (tyVarKind tv))
+tcGetCastedTyVar_maybe _ = Nothing
+
+tcGetTyVar_maybe :: Type -> Maybe TyVar
+tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty'
+tcGetTyVar_maybe (TyVarTy tv) = Just tv
+tcGetTyVar_maybe _ = Nothing
+
+tcGetTyVar :: String -> Type -> TyVar
+tcGetTyVar msg ty
+ = case tcGetTyVar_maybe ty of
+ Just tv -> tv
+ Nothing -> pprPanic msg (ppr ty)
+
+tcIsTyVarTy :: Type -> Bool
+tcIsTyVarTy ty | Just ty' <- tcView ty = tcIsTyVarTy ty'
+tcIsTyVarTy (CastTy ty _) = tcIsTyVarTy ty -- look through casts, as
+ -- this is only used for
+ -- e.g., FlexibleContexts
+tcIsTyVarTy (TyVarTy _) = True
+tcIsTyVarTy _ = False
+
+-----------------------
+tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type])
+-- Split the type of a dictionary function
+-- We don't use tcSplitSigmaTy, because a DFun may (with NDP)
+-- have non-Pred arguments, such as
+-- df :: forall m. (forall b. Eq b => Eq (m b)) -> C m
+--
+-- Also NB splitFunTys, not tcSplitFunTys;
+-- the latter specifically stops at PredTy arguments,
+-- and we don't want to do that here
+tcSplitDFunTy ty
+ = case tcSplitForAllTys ty of { (tvs, rho) ->
+ case splitFunTys rho of { (theta, tau) ->
+ case tcSplitDFunHead tau of { (clas, tys) ->
+ (tvs, theta, clas, tys) }}}
+
+tcSplitDFunHead :: Type -> (Class, [Type])
+tcSplitDFunHead = getClassPredTys
+
+tcSplitMethodTy :: Type -> ([TyVar], PredType, Type)
+-- A class method (selector) always has a type like
+-- forall as. C as => blah
+-- So if the class looks like
+-- class C a where
+-- op :: forall b. (Eq a, Ix b) => a -> b
+-- the class method type looks like
+-- op :: forall a. C a => forall b. (Eq a, Ix b) => a -> b
+--
+-- tcSplitMethodTy just peels off the outer forall and
+-- that first predicate
+tcSplitMethodTy ty
+ | (sel_tyvars,sel_rho) <- tcSplitForAllTys ty
+ , Just (first_pred, local_meth_ty) <- tcSplitPredFunTy_maybe sel_rho
+ = (sel_tyvars, first_pred, local_meth_ty)
+ | otherwise
+ = pprPanic "tcSplitMethodTy" (ppr ty)
+
+
+{- *********************************************************************
+* *
+ Type equalities
+* *
+********************************************************************* -}
+
+tcEqKind :: HasDebugCallStack => TcKind -> TcKind -> Bool
+tcEqKind = tcEqType
+
+tcEqType :: HasDebugCallStack => TcType -> TcType -> Bool
+-- tcEqType is a proper implements the same Note [Non-trivial definitional
+-- equality] (in GHC.Core.TyCo.Rep) as `eqType`, but Type.eqType believes (* ==
+-- Constraint), and that is NOT what we want in the type checker!
+tcEqType ty1 ty2
+ = tc_eq_type False False ki1 ki2
+ && tc_eq_type False False ty1 ty2
+ where
+ ki1 = tcTypeKind ty1
+ ki2 = tcTypeKind ty2
+
+-- | Just like 'tcEqType', but will return True for types of different kinds
+-- as long as their non-coercion structure is identical.
+tcEqTypeNoKindCheck :: TcType -> TcType -> Bool
+tcEqTypeNoKindCheck ty1 ty2
+ = tc_eq_type False False ty1 ty2
+
+-- | Like 'tcEqType', but returns True if the /visible/ part of the types
+-- are equal, even if they are really unequal (in the invisible bits)
+tcEqTypeVis :: TcType -> TcType -> Bool
+tcEqTypeVis ty1 ty2 = tc_eq_type False True ty1 ty2
+
+-- | Like 'pickyEqTypeVis', but returns a Bool for convenience
+pickyEqType :: TcType -> TcType -> Bool
+-- Check when two types _look_ the same, _including_ synonyms.
+-- So (pickyEqType String [Char]) returns False
+-- This ignores kinds and coercions, because this is used only for printing.
+pickyEqType ty1 ty2 = tc_eq_type True False ty1 ty2
+
+
+
+-- | Real worker for 'tcEqType'. No kind check!
+tc_eq_type :: Bool -- ^ True <=> do not expand type synonyms
+ -> Bool -- ^ True <=> compare visible args only
+ -> Type -> Type
+ -> Bool
+-- Flags False, False is the usual setting for tc_eq_type
+tc_eq_type keep_syns vis_only orig_ty1 orig_ty2
+ = go orig_env orig_ty1 orig_ty2
+ where
+ go :: RnEnv2 -> Type -> Type -> Bool
+ go env t1 t2 | not keep_syns, Just t1' <- tcView t1 = go env t1' t2
+ go env t1 t2 | not keep_syns, Just t2' <- tcView t2 = go env t1 t2'
+
+ go env (TyVarTy tv1) (TyVarTy tv2)
+ = rnOccL env tv1 == rnOccR env tv2
+
+ go _ (LitTy lit1) (LitTy lit2)
+ = lit1 == lit2
+
+ go env (ForAllTy (Bndr tv1 vis1) ty1)
+ (ForAllTy (Bndr tv2 vis2) ty2)
+ = vis1 == vis2
+ && (vis_only || go env (varType tv1) (varType tv2))
+ && go (rnBndr2 env tv1 tv2) ty1 ty2
+
+ -- Make sure we handle all FunTy cases since falling through to the
+ -- AppTy case means that tcRepSplitAppTy_maybe may see an unzonked
+ -- kind variable, which causes things to blow up.
+ go env (FunTy _ arg1 res1) (FunTy _ arg2 res2)
+ = go env arg1 arg2 && go env res1 res2
+ go env ty (FunTy _ arg res) = eqFunTy env arg res ty
+ go env (FunTy _ arg res) ty = eqFunTy env arg res ty
+
+ -- See Note [Equality on AppTys] in GHC.Core.Type
+ go env (AppTy s1 t1) ty2
+ | Just (s2, t2) <- tcRepSplitAppTy_maybe ty2
+ = go env s1 s2 && go env t1 t2
+ go env ty1 (AppTy s2 t2)
+ | Just (s1, t1) <- tcRepSplitAppTy_maybe ty1
+ = go env s1 s2 && go env t1 t2
+
+ go env (TyConApp tc1 ts1) (TyConApp tc2 ts2)
+ = tc1 == tc2 && gos env (tc_vis tc1) ts1 ts2
+
+ go env (CastTy t1 _) t2 = go env t1 t2
+ go env t1 (CastTy t2 _) = go env t1 t2
+ go _ (CoercionTy {}) (CoercionTy {}) = True
+
+ go _ _ _ = False
+
+ gos _ _ [] [] = True
+ gos env (ig:igs) (t1:ts1) (t2:ts2) = (ig || go env t1 t2)
+ && gos env igs ts1 ts2
+ gos _ _ _ _ = False
+
+ tc_vis :: TyCon -> [Bool] -- True for the fields we should ignore
+ tc_vis tc | vis_only = inviss ++ repeat False -- Ignore invisibles
+ | otherwise = repeat False -- Ignore nothing
+ -- The repeat False is necessary because tycons
+ -- can legitimately be oversaturated
+ where
+ bndrs = tyConBinders tc
+ inviss = map isInvisibleTyConBinder bndrs
+
+ orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2]
+
+ -- @eqFunTy arg res ty@ is True when @ty@ equals @FunTy arg res@. This is
+ -- sometimes hard to know directly because @ty@ might have some casts
+ -- obscuring the FunTy. And 'splitAppTy' is difficult because we can't
+ -- always extract a RuntimeRep (see Note [xyz]) if the kind of the arg or
+ -- res is unzonked/unflattened. Thus this function, which handles this
+ -- corner case.
+ eqFunTy :: RnEnv2 -> Type -> Type -> Type -> Bool
+ -- Last arg is /not/ FunTy
+ eqFunTy env arg res ty@(AppTy{}) = get_args ty []
+ where
+ get_args :: Type -> [Type] -> Bool
+ get_args (AppTy f x) args = get_args f (x:args)
+ get_args (CastTy t _) args = get_args t args
+ get_args (TyConApp tc tys) args
+ | tc == funTyCon
+ , [_, _, arg', res'] <- tys ++ args
+ = go env arg arg' && go env res res'
+ get_args _ _ = False
+ eqFunTy _ _ _ _ = False
+
+{- *********************************************************************
+* *
+ Predicate types
+* *
+************************************************************************
+
+Deconstructors and tests on predicate types
+
+Note [Kind polymorphic type classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ class C f where... -- C :: forall k. k -> Constraint
+ g :: forall (f::*). C f => f -> f
+
+Here the (C f) in the signature is really (C * f), and we
+don't want to complain that the * isn't a type variable!
+-}
+
+isTyVarClassPred :: PredType -> Bool
+isTyVarClassPred ty = case getClassPredTys_maybe ty of
+ Just (_, tys) -> all isTyVarTy tys
+ _ -> False
+
+-------------------------
+checkValidClsArgs :: Bool -> Class -> [KindOrType] -> Bool
+-- If the Bool is True (flexible contexts), return True (i.e. ok)
+-- Otherwise, check that the type (not kind) args are all headed by a tyvar
+-- E.g. (Eq a) accepted, (Eq (f a)) accepted, but (Eq Int) rejected
+-- This function is here rather than in GHC.Tc.Validity because it is
+-- called from GHC.Tc.Solver, which itself is imported by GHC.Tc.Validity
+checkValidClsArgs flexible_contexts cls kts
+ | flexible_contexts = True
+ | otherwise = all hasTyVarHead tys
+ where
+ tys = filterOutInvisibleTypes (classTyCon cls) kts
+
+hasTyVarHead :: Type -> Bool
+-- Returns true of (a t1 .. tn), where 'a' is a type variable
+hasTyVarHead ty -- Haskell 98 allows predicates of form
+ | tcIsTyVarTy ty = True -- C (a ty1 .. tyn)
+ | otherwise -- where a is a type variable
+ = case tcSplitAppTy_maybe ty of
+ Just (ty, _) -> hasTyVarHead ty
+ Nothing -> False
+
+evVarPred :: EvVar -> PredType
+evVarPred var = varType var
+ -- Historical note: I used to have an ASSERT here,
+ -- checking (isEvVarType (varType var)). But with something like
+ -- f :: c => _ -> _
+ -- we end up with (c :: kappa), and (kappa ~ Constraint). Until
+ -- we solve and zonk (which there is no particular reason to do for
+ -- partial signatures, (isEvVarType kappa) will return False. But
+ -- nothing is wrong. So I just removed the ASSERT.
+
+------------------
+-- | When inferring types, should we quantify over a given predicate?
+-- Generally true of classes; generally false of equality constraints.
+-- Equality constraints that mention quantified type variables and
+-- implicit variables complicate the story. See Notes
+-- [Inheriting implicit parameters] and [Quantifying over equality constraints]
+pickQuantifiablePreds
+ :: TyVarSet -- Quantifying over these
+ -> TcThetaType -- Proposed constraints to quantify
+ -> TcThetaType -- A subset that we can actually quantify
+-- This function decides whether a particular constraint should be
+-- quantified over, given the type variables that are being quantified
+pickQuantifiablePreds qtvs theta
+ = let flex_ctxt = True in -- Quantify over non-tyvar constraints, even without
+ -- -XFlexibleContexts: see #10608, #10351
+ -- flex_ctxt <- xoptM Opt_FlexibleContexts
+ mapMaybe (pick_me flex_ctxt) theta
+ where
+ pick_me flex_ctxt pred
+ = case classifyPredType pred of
+
+ ClassPred cls tys
+ | Just {} <- isCallStackPred cls tys
+ -- NEVER infer a CallStack constraint. Otherwise we let
+ -- the constraints bubble up to be solved from the outer
+ -- context, or be defaulted when we reach the top-level.
+ -- See Note [Overview of implicit CallStacks]
+ -> Nothing
+
+ | isIPClass cls
+ -> Just pred -- See note [Inheriting implicit parameters]
+
+ | pick_cls_pred flex_ctxt cls tys
+ -> Just pred
+
+ EqPred eq_rel ty1 ty2
+ | quantify_equality eq_rel ty1 ty2
+ , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2
+ -- boxEqPred: See Note [Lift equality constraints when quantifying]
+ , pick_cls_pred flex_ctxt cls tys
+ -> Just (mkClassPred cls tys)
+
+ IrredPred ty
+ | tyCoVarsOfType ty `intersectsVarSet` qtvs
+ -> Just pred
+
+ _ -> Nothing
+
+
+ pick_cls_pred flex_ctxt cls tys
+ = tyCoVarsOfTypes tys `intersectsVarSet` qtvs
+ && (checkValidClsArgs flex_ctxt cls tys)
+ -- Only quantify over predicates that checkValidType
+ -- will pass! See #10351.
+
+ -- See Note [Quantifying over equality constraints]
+ quantify_equality NomEq ty1 ty2 = quant_fun ty1 || quant_fun ty2
+ quantify_equality ReprEq _ _ = True
+
+ quant_fun ty
+ = case tcSplitTyConApp_maybe ty of
+ Just (tc, tys) | isTypeFamilyTyCon tc
+ -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs
+ _ -> False
+
+boxEqPred :: EqRel -> Type -> Type -> Maybe (Class, [Type])
+-- Given (t1 ~# t2) or (t1 ~R# t2) return the boxed version
+-- (t1 ~ t2) or (t1 `Coercible` t2)
+boxEqPred eq_rel ty1 ty2
+ = case eq_rel of
+ NomEq | homo_kind -> Just (eqClass, [k1, ty1, ty2])
+ | otherwise -> Just (heqClass, [k1, k2, ty1, ty2])
+ ReprEq | homo_kind -> Just (coercibleClass, [k1, ty1, ty2])
+ | otherwise -> Nothing -- Sigh: we do not have hererogeneous Coercible
+ -- so we can't abstract over it
+ -- Nothing fundamental: we could add it
+ where
+ k1 = tcTypeKind ty1
+ k2 = tcTypeKind ty2
+ homo_kind = k1 `tcEqType` k2
+
+pickCapturedPreds
+ :: TyVarSet -- Quantifying over these
+ -> TcThetaType -- Proposed constraints to quantify
+ -> TcThetaType -- A subset that we can actually quantify
+-- A simpler version of pickQuantifiablePreds, used to winnow down
+-- the inferred constraints of a group of bindings, into those for
+-- one particular identifier
+pickCapturedPreds qtvs theta
+ = filter captured theta
+ where
+ captured pred = isIPPred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs)
+
+
+-- Superclasses
+
+type PredWithSCs a = (PredType, [PredType], a)
+
+mkMinimalBySCs :: forall a. (a -> PredType) -> [a] -> [a]
+-- Remove predicates that
+--
+-- - are the same as another predicate
+--
+-- - can be deduced from another by superclasses,
+--
+-- - are a reflexive equality (e.g * ~ *)
+-- (see Note [Remove redundant provided dicts] in GHC.Tc.TyCl.PatSyn)
+--
+-- The result is a subset of the input.
+-- The 'a' is just paired up with the PredType;
+-- typically it might be a dictionary Id
+mkMinimalBySCs get_pred xs = go preds_with_scs []
+ where
+ preds_with_scs :: [PredWithSCs a]
+ preds_with_scs = [ (pred, pred : transSuperClasses pred, x)
+ | x <- xs
+ , let pred = get_pred x ]
+
+ go :: [PredWithSCs a] -- Work list
+ -> [PredWithSCs a] -- Accumulating result
+ -> [a]
+ go [] min_preds
+ = reverse (map thdOf3 min_preds)
+ -- The 'reverse' isn't strictly necessary, but it
+ -- means that the results are returned in the same
+ -- order as the input, which is generally saner
+ go (work_item@(p,_,_) : work_list) min_preds
+ | EqPred _ t1 t2 <- classifyPredType p
+ , t1 `tcEqType` t2 -- See GHC.Tc.TyCl.PatSyn
+ -- Note [Remove redundant provided dicts]
+ = go work_list min_preds
+ | p `in_cloud` work_list || p `in_cloud` min_preds
+ = go work_list min_preds
+ | otherwise
+ = go work_list (work_item : min_preds)
+
+ in_cloud :: PredType -> [PredWithSCs a] -> Bool
+ in_cloud p ps = or [ p `tcEqType` p' | (_, scs, _) <- ps, p' <- scs ]
+
+transSuperClasses :: PredType -> [PredType]
+-- (transSuperClasses p) returns (p's superclasses) not including p
+-- Stop if you encounter the same class again
+-- See Note [Expanding superclasses]
+transSuperClasses p
+ = go emptyNameSet p
+ where
+ go :: NameSet -> PredType -> [PredType]
+ go rec_clss p
+ | ClassPred cls tys <- classifyPredType p
+ , let cls_nm = className cls
+ , not (cls_nm `elemNameSet` rec_clss)
+ , let rec_clss' | isCTupleClass cls = rec_clss
+ | otherwise = rec_clss `extendNameSet` cls_nm
+ = [ p' | sc <- immSuperClasses cls tys
+ , p' <- sc : go rec_clss' sc ]
+ | otherwise
+ = []
+
+immSuperClasses :: Class -> [Type] -> [PredType]
+immSuperClasses cls tys
+ = substTheta (zipTvSubst tyvars tys) sc_theta
+ where
+ (tyvars,sc_theta,_,_) = classBigSig cls
+
+isImprovementPred :: PredType -> Bool
+-- Either it's an equality, or has some functional dependency
+isImprovementPred ty
+ = case classifyPredType ty of
+ EqPred NomEq t1 t2 -> not (t1 `tcEqType` t2)
+ EqPred ReprEq _ _ -> False
+ ClassPred cls _ -> classHasFds cls
+ IrredPred {} -> True -- Might have equalities after reduction?
+ ForAllPred {} -> False
+
+-- | Is the equality
+-- a ~r ...a....
+-- definitely insoluble or not?
+-- a ~r Maybe a -- Definitely insoluble
+-- a ~N ...(F a)... -- Not definitely insoluble
+-- -- Perhaps (F a) reduces to Int
+-- a ~R ...(N a)... -- Not definitely insoluble
+-- -- Perhaps newtype N a = MkN Int
+-- See Note [Occurs check error] in
+-- GHC.Tc.Solver.Canonical for the motivation for this function.
+isInsolubleOccursCheck :: EqRel -> TcTyVar -> TcType -> Bool
+isInsolubleOccursCheck eq_rel tv ty
+ = go ty
+ where
+ go ty | Just ty' <- tcView ty = go ty'
+ go (TyVarTy tv') = tv == tv' || go (tyVarKind tv')
+ go (LitTy {}) = False
+ go (AppTy t1 t2) = case eq_rel of -- See Note [AppTy and ReprEq]
+ NomEq -> go t1 || go t2
+ ReprEq -> go t1
+ go (FunTy _ t1 t2) = go t1 || go t2
+ go (ForAllTy (Bndr tv' _) inner_ty)
+ | tv' == tv = False
+ | otherwise = go (varType tv') || go inner_ty
+ go (CastTy ty _) = go ty -- ToDo: what about the coercion
+ go (CoercionTy _) = False -- ToDo: what about the coercion
+ go (TyConApp tc tys)
+ | isGenerativeTyCon tc role = any go tys
+ | otherwise = any go (drop (tyConArity tc) tys)
+ -- (a ~ F b a), where F has arity 1,
+ -- has an insoluble occurs check
+
+ role = eqRelRole eq_rel
+
+{- Note [Expanding superclasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we expand superclasses, we use the following algorithm:
+
+transSuperClasses( C tys ) returns the transitive superclasses
+ of (C tys), not including C itself
+
+For example
+ class C a b => D a b
+ class D b a => C a b
+
+Then
+ transSuperClasses( Ord ty ) = [Eq ty]
+ transSuperClasses( C ta tb ) = [D tb ta, C tb ta]
+
+Notice that in the recursive-superclass case we include C again at
+the end of the chain. One could exclude C in this case, but
+the code is more awkward and there seems no good reason to do so.
+(However C.f. GHC.Tc.Solver.Canonical.mk_strict_superclasses, which /does/
+appear to do so.)
+
+The algorithm is expand( so_far, pred ):
+
+ 1. If pred is not a class constraint, return empty set
+ Otherwise pred = C ts
+ 2. If C is in so_far, return empty set (breaks loops)
+ 3. Find the immediate superclasses constraints of (C ts)
+ 4. For each such sc_pred, return (sc_pred : expand( so_far+C, D ss )
+
+Notice that
+
+ * With normal Haskell-98 classes, the loop-detector will never bite,
+ so we'll get all the superclasses.
+
+ * We need the loop-breaker in case we have UndecidableSuperClasses on
+
+ * Since there is only a finite number of distinct classes, expansion
+ must terminate.
+
+ * The loop breaking is a bit conservative. Notably, a tuple class
+ could contain many times without threatening termination:
+ (Eq a, (Ord a, Ix a))
+ And this is try of any class that we can statically guarantee
+ as non-recursive (in some sense). For now, we just make a special
+ case for tuples. Something better would be cool.
+
+See also GHC.Tc.TyCl.Utils.checkClassCycles.
+
+Note [Lift equality constraints when quantifying]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We can't quantify over a constraint (t1 ~# t2) because that isn't a
+predicate type; see Note [Types for coercions, predicates, and evidence]
+in GHC.Core.TyCo.Rep.
+
+So we have to 'lift' it to (t1 ~ t2). Similarly (~R#) must be lifted
+to Coercible.
+
+This tiresome lifting is the reason that pick_me (in
+pickQuantifiablePreds) returns a Maybe rather than a Bool.
+
+Note [Quantifying over equality constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Should we quantify over an equality constraint (s ~ t)? In general, we don't.
+Doing so may simply postpone a type error from the function definition site to
+its call site. (At worst, imagine (Int ~ Bool)).
+
+However, consider this
+ forall a. (F [a] ~ Int) => blah
+Should we quantify over the (F [a] ~ Int)? Perhaps yes, because at the call
+site we will know 'a', and perhaps we have instance F [Bool] = Int.
+So we *do* quantify over a type-family equality where the arguments mention
+the quantified variables.
+
+Note [Inheriting implicit parameters]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+
+ f x = (x::Int) + ?y
+
+where f is *not* a top-level binding.
+From the RHS of f we'll get the constraint (?y::Int).
+There are two types we might infer for f:
+
+ f :: Int -> Int
+
+(so we get ?y from the context of f's definition), or
+
+ f :: (?y::Int) => Int -> Int
+
+At first you might think the first was better, because then
+?y behaves like a free variable of the definition, rather than
+having to be passed at each call site. But of course, the WHOLE
+IDEA is that ?y should be passed at each call site (that's what
+dynamic binding means) so we'd better infer the second.
+
+BOTTOM LINE: when *inferring types* you must quantify over implicit
+parameters, *even if* they don't mention the bound type variables.
+Reason: because implicit parameters, uniquely, have local instance
+declarations. See pickQuantifiablePreds.
+
+Note [Quantifying over equality constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Should we quantify over an equality constraint (s ~ t)? In general, we don't.
+Doing so may simply postpone a type error from the function definition site to
+its call site. (At worst, imagine (Int ~ Bool)).
+
+However, consider this
+ forall a. (F [a] ~ Int) => blah
+Should we quantify over the (F [a] ~ Int). Perhaps yes, because at the call
+site we will know 'a', and perhaps we have instance F [Bool] = Int.
+So we *do* quantify over a type-family equality where the arguments mention
+the quantified variables.
+
+************************************************************************
+* *
+ Classifying types
+* *
+************************************************************************
+-}
+
+isSigmaTy :: TcType -> Bool
+-- isSigmaTy returns true of any qualified type. It doesn't
+-- *necessarily* have any foralls. E.g
+-- f :: (?x::Int) => Int -> Int
+isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty'
+isSigmaTy (ForAllTy {}) = True
+isSigmaTy (FunTy { ft_af = InvisArg }) = True
+isSigmaTy _ = False
+
+isRhoTy :: TcType -> Bool -- True of TcRhoTypes; see Note [TcRhoType]
+isRhoTy ty | Just ty' <- tcView ty = isRhoTy ty'
+isRhoTy (ForAllTy {}) = False
+isRhoTy (FunTy { ft_af = VisArg, ft_res = r }) = isRhoTy r
+isRhoTy _ = True
+
+-- | Like 'isRhoTy', but also says 'True' for 'Infer' types
+isRhoExpTy :: ExpType -> Bool
+isRhoExpTy (Check ty) = isRhoTy ty
+isRhoExpTy (Infer {}) = True
+
+isOverloadedTy :: Type -> Bool
+-- Yes for a type of a function that might require evidence-passing
+-- Used only by bindLocalMethods
+isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty'
+isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty
+isOverloadedTy (FunTy { ft_af = InvisArg }) = True
+isOverloadedTy _ = False
+
+isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy,
+ isUnitTy, isCharTy, isAnyTy :: Type -> Bool
+isFloatTy = is_tc floatTyConKey
+isDoubleTy = is_tc doubleTyConKey
+isIntegerTy = is_tc integerTyConKey
+isIntTy = is_tc intTyConKey
+isWordTy = is_tc wordTyConKey
+isBoolTy = is_tc boolTyConKey
+isUnitTy = is_tc unitTyConKey
+isCharTy = is_tc charTyConKey
+isAnyTy = is_tc anyTyConKey
+
+-- | Does a type represent a floating-point number?
+isFloatingTy :: Type -> Bool
+isFloatingTy ty = isFloatTy ty || isDoubleTy ty
+
+-- | Is a type 'String'?
+isStringTy :: Type -> Bool
+isStringTy ty
+ = case tcSplitTyConApp_maybe ty of
+ Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty
+ _ -> False
+
+-- | Is a type a 'CallStack'?
+isCallStackTy :: Type -> Bool
+isCallStackTy ty
+ | Just tc <- tyConAppTyCon_maybe ty
+ = tc `hasKey` callStackTyConKey
+ | otherwise
+ = False
+
+-- | Is a 'PredType' a 'CallStack' implicit parameter?
+--
+-- If so, return the name of the parameter.
+isCallStackPred :: Class -> [Type] -> Maybe FastString
+isCallStackPred cls tys
+ | [ty1, ty2] <- tys
+ , isIPClass cls
+ , isCallStackTy ty2
+ = isStrLitTy ty1
+ | otherwise
+ = Nothing
+
+is_tc :: Unique -> Type -> Bool
+-- Newtypes are opaque to this
+is_tc uniq ty = case tcSplitTyConApp_maybe ty of
+ Just (tc, _) -> uniq == getUnique tc
+ Nothing -> False
+
+-- | Does the given tyvar appear at the head of a chain of applications
+-- (a t1 ... tn)
+isTyVarHead :: TcTyVar -> TcType -> Bool
+isTyVarHead tv (TyVarTy tv') = tv == tv'
+isTyVarHead tv (AppTy fun _) = isTyVarHead tv fun
+isTyVarHead tv (CastTy ty _) = isTyVarHead tv ty
+isTyVarHead _ (TyConApp {}) = False
+isTyVarHead _ (LitTy {}) = False
+isTyVarHead _ (ForAllTy {}) = False
+isTyVarHead _ (FunTy {}) = False
+isTyVarHead _ (CoercionTy {}) = False
+
+
+{- Note [AppTy and ReprEq]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider a ~R# b a
+ a ~R# a b
+
+The former is /not/ a definite error; we might instantiate 'b' with Id
+ newtype Id a = MkId a
+but the latter /is/ a definite error.
+
+On the other hand, with nominal equality, both are definite errors
+-}
+
+isRigidTy :: TcType -> Bool
+isRigidTy ty
+ | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal
+ | Just {} <- tcSplitAppTy_maybe ty = True
+ | isForAllTy ty = True
+ | otherwise = False
+
+
+-- | Is this type *almost function-free*? See Note [Almost function-free]
+-- in GHC.Tc.Types
+isAlmostFunctionFree :: TcType -> Bool
+isAlmostFunctionFree ty | Just ty' <- tcView ty = isAlmostFunctionFree ty'
+isAlmostFunctionFree (TyVarTy {}) = True
+isAlmostFunctionFree (AppTy ty1 ty2) = isAlmostFunctionFree ty1 &&
+ isAlmostFunctionFree ty2
+isAlmostFunctionFree (TyConApp tc args)
+ | isTypeFamilyTyCon tc = False
+ | otherwise = all isAlmostFunctionFree args
+isAlmostFunctionFree (ForAllTy bndr _) = isAlmostFunctionFree (binderType bndr)
+isAlmostFunctionFree (FunTy _ ty1 ty2) = isAlmostFunctionFree ty1 &&
+ isAlmostFunctionFree ty2
+isAlmostFunctionFree (LitTy {}) = True
+isAlmostFunctionFree (CastTy ty _) = isAlmostFunctionFree ty
+isAlmostFunctionFree (CoercionTy {}) = True
+
+{-
+************************************************************************
+* *
+\subsection{Misc}
+* *
+************************************************************************
+
+Note [Visible type application]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+GHC implements a generalisation of the algorithm described in the
+"Visible Type Application" paper (available from
+http://www.cis.upenn.edu/~sweirich/publications.html). A key part
+of that algorithm is to distinguish user-specified variables from inferred
+variables. For example, the following should typecheck:
+
+ f :: forall a b. a -> b -> b
+ f = const id
+
+ g = const id
+
+ x = f @Int @Bool 5 False
+ y = g 5 @Bool False
+
+The idea is that we wish to allow visible type application when we are
+instantiating a specified, fixed variable. In practice, specified, fixed
+variables are either written in a type signature (or
+annotation), OR are imported from another module. (We could do better here,
+for example by doing SCC analysis on parts of a module and considering any
+type from outside one's SCC to be fully specified, but this is very confusing to
+users. The simple rule above is much more straightforward and predictable.)
+
+So, both of f's quantified variables are specified and may be instantiated.
+But g has no type signature, so only id's variable is specified (because id
+is imported). We write the type of g as forall {a}. a -> forall b. b -> b.
+Note that the a is in braces, meaning it cannot be instantiated with
+visible type application.
+
+Tracking specified vs. inferred variables is done conveniently by a field
+in TyBinder.
+
+-}
+
+deNoteType :: Type -> Type
+-- Remove all *outermost* type synonyms and other notes
+deNoteType ty | Just ty' <- coreView ty = deNoteType ty'
+deNoteType ty = ty
+
+{-
+Find the free tycons and classes of a type. This is used in the front
+end of the compiler.
+-}
+
+{-
+************************************************************************
+* *
+\subsection[TysWiredIn-ext-type]{External types}
+* *
+************************************************************************
+
+The compiler's foreign function interface supports the passing of a
+restricted set of types as arguments and results (the restricting factor
+being the )
+-}
+
+tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type)
+-- (tcSplitIOType_maybe t) returns Just (IO,t',co)
+-- if co : t ~ IO t'
+-- returns Nothing otherwise
+tcSplitIOType_maybe ty
+ = case tcSplitTyConApp_maybe ty of
+ Just (io_tycon, [io_res_ty])
+ | io_tycon `hasKey` ioTyConKey ->
+ Just (io_tycon, io_res_ty)
+ _ ->
+ Nothing
+
+isFFITy :: Type -> Bool
+-- True for any TyCon that can possibly be an arg or result of an FFI call
+isFFITy ty = isValid (checkRepTyCon legalFFITyCon ty)
+
+isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity
+-- Checks for valid argument type for a 'foreign import'
+isFFIArgumentTy dflags safety ty
+ = checkRepTyCon (legalOutgoingTyCon dflags safety) ty
+
+isFFIExternalTy :: Type -> Validity
+-- Types that are allowed as arguments of a 'foreign export'
+isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
+
+isFFIImportResultTy :: DynFlags -> Type -> Validity
+isFFIImportResultTy dflags ty
+ = checkRepTyCon (legalFIResultTyCon dflags) ty
+
+isFFIExportResultTy :: Type -> Validity
+isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
+
+isFFIDynTy :: Type -> Type -> Validity
+-- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of
+-- either, and the wrapped function type must be equal to the given type.
+-- We assume that all types have been run through normaliseFfiType, so we don't
+-- need to worry about expanding newtypes here.
+isFFIDynTy expected ty
+ -- Note [Foreign import dynamic]
+ -- In the example below, expected would be 'CInt -> IO ()', while ty would
+ -- be 'FunPtr (CDouble -> IO ())'.
+ | Just (tc, [ty']) <- splitTyConApp_maybe ty
+ , tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey]
+ , eqType ty' expected
+ = IsValid
+ | otherwise
+ = NotValid (vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma
+ , text " Actual:" <+> ppr ty ])
+
+isFFILabelTy :: Type -> Validity
+-- The type of a foreign label must be Ptr, FunPtr, or a newtype of either.
+isFFILabelTy ty = checkRepTyCon ok ty
+ where
+ ok tc | tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey
+ = IsValid
+ | otherwise
+ = NotValid (text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)")
+
+isFFIPrimArgumentTy :: DynFlags -> Type -> Validity
+-- Checks for valid argument type for a 'foreign import prim'
+-- Currently they must all be simple unlifted types, or the well-known type
+-- Any, which can be used to pass the address to a Haskell object on the heap to
+-- the foreign function.
+isFFIPrimArgumentTy dflags ty
+ | isAnyTy ty = IsValid
+ | otherwise = checkRepTyCon (legalFIPrimArgTyCon dflags) ty
+
+isFFIPrimResultTy :: DynFlags -> Type -> Validity
+-- Checks for valid result type for a 'foreign import prim' Currently
+-- it must be an unlifted type, including unboxed tuples, unboxed
+-- sums, or the well-known type Any.
+isFFIPrimResultTy dflags ty
+ | isAnyTy ty = IsValid
+ | otherwise = checkRepTyCon (legalFIPrimResultTyCon dflags) ty
+
+isFunPtrTy :: Type -> Bool
+isFunPtrTy ty
+ | Just (tc, [_]) <- splitTyConApp_maybe ty
+ = tc `hasKey` funPtrTyConKey
+ | otherwise
+ = False
+
+-- normaliseFfiType gets run before checkRepTyCon, so we don't
+-- need to worry about looking through newtypes or type functions
+-- here; that's already been taken care of.
+checkRepTyCon :: (TyCon -> Validity) -> Type -> Validity
+checkRepTyCon check_tc ty
+ = case splitTyConApp_maybe ty of
+ Just (tc, tys)
+ | isNewTyCon tc -> NotValid (hang msg 2 (mk_nt_reason tc tys $$ nt_fix))
+ | otherwise -> case check_tc tc of
+ IsValid -> IsValid
+ NotValid extra -> NotValid (msg $$ extra)
+ Nothing -> NotValid (quotes (ppr ty) <+> text "is not a data type")
+ where
+ msg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call"
+ mk_nt_reason tc tys
+ | null tys = text "because its data constructor is not in scope"
+ | otherwise = text "because the data constructor for"
+ <+> quotes (ppr tc) <+> text "is not in scope"
+ nt_fix = text "Possible fix: import the data constructor to bring it into scope"
+
+{-
+Note [Foreign import dynamic]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign
+type. Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'.
+
+We use isFFIDynTy to check whether a signature is well-formed. For example,
+given a (illegal) declaration like:
+
+foreign import ccall "dynamic"
+ foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO ()
+
+isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried
+result type 'CInt -> IO ()', and return False, as they are not equal.
+
+
+----------------------------------------------
+These chaps do the work; they are not exported
+----------------------------------------------
+-}
+
+legalFEArgTyCon :: TyCon -> Validity
+legalFEArgTyCon tc
+ -- It's illegal to make foreign exports that take unboxed
+ -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000
+ = boxedMarshalableTyCon tc
+
+legalFIResultTyCon :: DynFlags -> TyCon -> Validity
+legalFIResultTyCon dflags tc
+ | tc == unitTyCon = IsValid
+ | otherwise = marshalableTyCon dflags tc
+
+legalFEResultTyCon :: TyCon -> Validity
+legalFEResultTyCon tc
+ | tc == unitTyCon = IsValid
+ | otherwise = boxedMarshalableTyCon tc
+
+legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity
+-- Checks validity of types going from Haskell -> external world
+legalOutgoingTyCon dflags _ tc
+ = marshalableTyCon dflags tc
+
+legalFFITyCon :: TyCon -> Validity
+-- True for any TyCon that can possibly be an arg or result of an FFI call
+legalFFITyCon tc
+ | isUnliftedTyCon tc = IsValid
+ | tc == unitTyCon = IsValid
+ | otherwise = boxedMarshalableTyCon tc
+
+marshalableTyCon :: DynFlags -> TyCon -> Validity
+marshalableTyCon dflags tc
+ | isUnliftedTyCon tc
+ , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc)
+ , not (null (tyConPrimRep tc)) -- Note [Marshalling void]
+ = validIfUnliftedFFITypes dflags
+ | otherwise
+ = boxedMarshalableTyCon tc
+
+boxedMarshalableTyCon :: TyCon -> Validity
+boxedMarshalableTyCon tc
+ | getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
+ , int32TyConKey, int64TyConKey
+ , wordTyConKey, word8TyConKey, word16TyConKey
+ , word32TyConKey, word64TyConKey
+ , floatTyConKey, doubleTyConKey
+ , ptrTyConKey, funPtrTyConKey
+ , charTyConKey
+ , stablePtrTyConKey
+ , boolTyConKey
+ ]
+ = IsValid
+
+ | otherwise = NotValid empty
+
+legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity
+-- Check args of 'foreign import prim', only allow simple unlifted types.
+-- Strictly speaking it is unnecessary to ban unboxed tuples and sums here since
+-- currently they're of the wrong kind to use in function args anyway.
+legalFIPrimArgTyCon dflags tc
+ | isUnliftedTyCon tc
+ , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc)
+ = validIfUnliftedFFITypes dflags
+ | otherwise
+ = NotValid unlifted_only
+
+legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity
+-- Check result type of 'foreign import prim'. Allow simple unlifted
+-- types and also unboxed tuple and sum result types.
+legalFIPrimResultTyCon dflags tc
+ | isUnliftedTyCon tc
+ , isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc
+ || not (null (tyConPrimRep tc)) -- Note [Marshalling void]
+ = validIfUnliftedFFITypes dflags
+
+ | otherwise
+ = NotValid unlifted_only
+
+unlifted_only :: MsgDoc
+unlifted_only = text "foreign import prim only accepts simple unlifted types"
+
+validIfUnliftedFFITypes :: DynFlags -> Validity
+validIfUnliftedFFITypes dflags
+ | xopt LangExt.UnliftedFFITypes dflags = IsValid
+ | otherwise = NotValid (text "To marshal unlifted types, use UnliftedFFITypes")
+
+{-
+Note [Marshalling void]
+~~~~~~~~~~~~~~~~~~~~~~~
+We don't treat State# (whose PrimRep is VoidRep) as marshalable.
+In turn that means you can't write
+ foreign import foo :: Int -> State# RealWorld
+
+Reason: the back end falls over with panic "primRepHint:VoidRep";
+ and there is no compelling reason to permit it
+-}
+
+{-
+************************************************************************
+* *
+ The "Paterson size" of a type
+* *
+************************************************************************
+-}
+
+{-
+Note [Paterson conditions on PredTypes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We are considering whether *class* constraints terminate
+(see Note [Paterson conditions]). Precisely, the Paterson conditions
+would have us check that "the constraint has fewer constructors and variables
+(taken together and counting repetitions) than the head.".
+
+However, we can be a bit more refined by looking at which kind of constraint
+this actually is. There are two main tricks:
+
+ 1. It seems like it should be OK not to count the tuple type constructor
+ for a PredType like (Show a, Eq a) :: Constraint, since we don't
+ count the "implicit" tuple in the ThetaType itself.
+
+ In fact, the Paterson test just checks *each component* of the top level
+ ThetaType against the size bound, one at a time. By analogy, it should be
+ OK to return the size of the *largest* tuple component as the size of the
+ whole tuple.
+
+ 2. Once we get into an implicit parameter or equality we
+ can't get back to a class constraint, so it's safe
+ to say "size 0". See #4200.
+
+NB: we don't want to detect PredTypes in sizeType (and then call
+sizePred on them), or we might get an infinite loop if that PredType
+is irreducible. See #5581.
+-}
+
+type TypeSize = IntWithInf
+
+sizeType :: Type -> TypeSize
+-- Size of a type: the number of variables and constructors
+-- Ignore kinds altogether
+sizeType = go
+ where
+ go ty | Just exp_ty <- tcView ty = go exp_ty
+ go (TyVarTy {}) = 1
+ go (TyConApp tc tys)
+ | isTypeFamilyTyCon tc = infinity -- Type-family applications can
+ -- expand to any arbitrary size
+ | otherwise = sizeTypes (filterOutInvisibleTypes tc tys) + 1
+ -- Why filter out invisible args? I suppose any
+ -- size ordering is sound, but why is this better?
+ -- I came across this when investigating #14010.
+ go (LitTy {}) = 1
+ go (FunTy _ arg res) = go arg + go res + 1
+ go (AppTy fun arg) = go fun + go arg
+ go (ForAllTy (Bndr tv vis) ty)
+ | isVisibleArgFlag vis = go (tyVarKind tv) + go ty + 1
+ | otherwise = go ty + 1
+ go (CastTy ty _) = go ty
+ go (CoercionTy {}) = 0
+
+sizeTypes :: [Type] -> TypeSize
+sizeTypes tys = sum (map sizeType tys)
+
+-----------------------------------------------------------------------------------
+-----------------------------------------------------------------------------------
+-----------------------
+-- | For every arg a tycon can take, the returned list says True if the argument
+-- is taken visibly, and False otherwise. Ends with an infinite tail of Trues to
+-- allow for oversaturation.
+tcTyConVisibilities :: TyCon -> [Bool]
+tcTyConVisibilities tc = tc_binder_viss ++ tc_return_kind_viss ++ repeat True
+ where
+ tc_binder_viss = map isVisibleTyConBinder (tyConBinders tc)
+ tc_return_kind_viss = map isVisibleBinder (fst $ tcSplitPiTys (tyConResKind tc))
+
+-- | If the tycon is applied to the types, is the next argument visible?
+isNextTyConArgVisible :: TyCon -> [Type] -> Bool
+isNextTyConArgVisible tc tys
+ = tcTyConVisibilities tc `getNth` length tys
+
+-- | Should this type be applied to a visible argument?
+isNextArgVisible :: TcType -> Bool
+isNextArgVisible ty
+ | Just (bndr, _) <- tcSplitPiTy_maybe ty = isVisibleBinder bndr
+ | otherwise = True
+ -- this second case might happen if, say, we have an unzonked TauTv.
+ -- But TauTvs can't range over types that take invisible arguments
diff --git a/compiler/GHC/Tc/Utils/TcType.hs-boot b/compiler/GHC/Tc/Utils/TcType.hs-boot
new file mode 100644
index 0000000000..481d261f79
--- /dev/null
+++ b/compiler/GHC/Tc/Utils/TcType.hs-boot
@@ -0,0 +1,8 @@
+module GHC.Tc.Utils.TcType where
+import Outputable( SDoc )
+
+data MetaDetails
+
+data TcTyVarDetails
+pprTcTyVarDetails :: TcTyVarDetails -> SDoc
+vanillaSkolemTv :: TcTyVarDetails
diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs
new file mode 100644
index 0000000000..f6d934af9a
--- /dev/null
+++ b/compiler/GHC/Tc/Utils/Unify.hs
@@ -0,0 +1,2331 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+-}
+
+{-# LANGUAGE CPP, DeriveFunctor, MultiWayIf, TupleSections,
+ ScopedTypeVariables #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+
+-- | Type subsumption and unification
+module GHC.Tc.Utils.Unify (
+ -- Full-blown subsumption
+ tcWrapResult, tcWrapResultO, tcSkolemise, tcSkolemiseET,
+ tcSubTypeHR, tcSubTypeO, tcSubType_NC, tcSubTypeDS,
+ tcSubTypeDS_NC_O, tcSubTypeET,
+ checkConstraints, checkTvConstraints,
+ buildImplicationFor, emitResidualTvConstraint,
+
+ -- Various unifications
+ unifyType, unifyKind,
+ uType, promoteTcType,
+ swapOverTyVars, canSolveByUnification,
+
+ --------------------------------
+ -- Holes
+ tcInferInst, tcInferNoInst,
+ matchExpectedListTy,
+ matchExpectedTyConApp,
+ matchExpectedAppTy,
+ matchExpectedFunTys,
+ matchActualFunTys, matchActualFunTysPart,
+ matchExpectedFunKind,
+
+ metaTyVarUpdateOK, occCheckForErrors, MetaTyVarUpdateResult(..)
+
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHC.Hs
+import GHC.Core.TyCo.Rep
+import GHC.Core.TyCo.Ppr( debugPprType )
+import GHC.Tc.Utils.TcMType
+import GHC.Tc.Utils.Monad
+import GHC.Tc.Utils.TcType
+import GHC.Core.Type
+import GHC.Core.Coercion
+import GHC.Tc.Types.Evidence
+import GHC.Tc.Types.Constraint
+import GHC.Core.Predicate
+import GHC.Tc.Types.Origin
+import GHC.Types.Name( isSystemName )
+import GHC.Tc.Utils.Instantiate
+import GHC.Core.TyCon
+import TysWiredIn
+import TysPrim( tYPE )
+import GHC.Types.Var as Var
+import GHC.Types.Var.Set
+import GHC.Types.Var.Env
+import ErrUtils
+import GHC.Driver.Session
+import GHC.Types.Basic
+import Bag
+import Util
+import qualified GHC.LanguageExtensions as LangExt
+import Outputable
+
+import Data.Maybe( isNothing )
+import Control.Monad
+import Control.Arrow ( second )
+
+{-
+************************************************************************
+* *
+ matchExpected functions
+* *
+************************************************************************
+
+Note [Herald for matchExpectedFunTys]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The 'herald' always looks like:
+ "The equation(s) for 'f' have"
+ "The abstraction (\x.e) takes"
+ "The section (+ x) expects"
+ "The function 'f' is applied to"
+
+This is used to construct a message of form
+
+ The abstraction `\Just 1 -> ...' takes two arguments
+ but its type `Maybe a -> a' has only one
+
+ The equation(s) for `f' have two arguments
+ but its type `Maybe a -> a' has only one
+
+ The section `(f 3)' requires 'f' to take two arguments
+ but its type `Int -> Int' has only one
+
+ The function 'f' is applied to two arguments
+ but its type `Int -> Int' has only one
+
+When visible type applications (e.g., `f @Int 1 2`, as in #13902) enter the
+picture, we have a choice in deciding whether to count the type applications as
+proper arguments:
+
+ The function 'f' is applied to one visible type argument
+ and two value arguments
+ but its type `forall a. a -> a` has only one visible type argument
+ and one value argument
+
+Or whether to include the type applications as part of the herald itself:
+
+ The expression 'f @Int' is applied to two arguments
+ but its type `Int -> Int` has only one
+
+The latter is easier to implement and is arguably easier to understand, so we
+choose to implement that option.
+
+Note [matchExpectedFunTys]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+matchExpectedFunTys checks that a sigma has the form
+of an n-ary function. It passes the decomposed type to the
+thing_inside, and returns a wrapper to coerce between the two types
+
+It's used wherever a language construct must have a functional type,
+namely:
+ A lambda expression
+ A function definition
+ An operator section
+
+This function must be written CPS'd because it needs to fill in the
+ExpTypes produced for arguments before it can fill in the ExpType
+passed in.
+
+-}
+
+-- Use this one when you have an "expected" type.
+matchExpectedFunTys :: forall a.
+ SDoc -- See Note [Herald for matchExpectedFunTys]
+ -> Arity
+ -> ExpRhoType -- deeply skolemised
+ -> ([ExpSigmaType] -> ExpRhoType -> TcM a)
+ -- must fill in these ExpTypes here
+ -> TcM (a, HsWrapper)
+-- If matchExpectedFunTys n ty = (_, wrap)
+-- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty,
+-- where [t1, ..., tn], ty_r are passed to the thing_inside
+matchExpectedFunTys herald arity orig_ty thing_inside
+ = case orig_ty of
+ Check ty -> go [] arity ty
+ _ -> defer [] arity orig_ty
+ where
+ go acc_arg_tys 0 ty
+ = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType ty)
+ ; return (result, idHsWrapper) }
+
+ go acc_arg_tys n ty
+ | Just ty' <- tcView ty = go acc_arg_tys n ty'
+
+ go acc_arg_tys n (FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty })
+ = ASSERT( af == VisArg )
+ do { (result, wrap_res) <- go (mkCheckExpType arg_ty : acc_arg_tys)
+ (n-1) res_ty
+ ; return ( result
+ , mkWpFun idHsWrapper wrap_res arg_ty res_ty doc ) }
+ where
+ doc = text "When inferring the argument type of a function with type" <+>
+ quotes (ppr orig_ty)
+
+ go acc_arg_tys n ty@(TyVarTy tv)
+ | isMetaTyVar tv
+ = do { cts <- readMetaTyVar tv
+ ; case cts of
+ Indirect ty' -> go acc_arg_tys n ty'
+ Flexi -> defer acc_arg_tys n (mkCheckExpType ty) }
+
+ -- In all other cases we bale out into ordinary unification
+ -- However unlike the meta-tyvar case, we are sure that the
+ -- number of arguments doesn't match arity of the original
+ -- type, so we can add a bit more context to the error message
+ -- (cf #7869).
+ --
+ -- It is not always an error, because specialized type may have
+ -- different arity, for example:
+ --
+ -- > f1 = f2 'a'
+ -- > f2 :: Monad m => m Bool
+ -- > f2 = undefined
+ --
+ -- But in that case we add specialized type into error context
+ -- anyway, because it may be useful. See also #9605.
+ go acc_arg_tys n ty = addErrCtxtM mk_ctxt $
+ defer acc_arg_tys n (mkCheckExpType ty)
+
+ ------------
+ defer :: [ExpSigmaType] -> Arity -> ExpRhoType -> TcM (a, HsWrapper)
+ defer acc_arg_tys n fun_ty
+ = do { more_arg_tys <- replicateM n newInferExpTypeNoInst
+ ; res_ty <- newInferExpTypeInst
+ ; result <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty
+ ; more_arg_tys <- mapM readExpType more_arg_tys
+ ; res_ty <- readExpType res_ty
+ ; let unif_fun_ty = mkVisFunTys more_arg_tys res_ty
+ ; wrap <- tcSubTypeDS AppOrigin GenSigCtxt unif_fun_ty fun_ty
+ -- Not a good origin at all :-(
+ ; return (result, wrap) }
+
+ ------------
+ mk_ctxt :: TidyEnv -> TcM (TidyEnv, MsgDoc)
+ mk_ctxt env = do { (env', ty) <- zonkTidyTcType env orig_tc_ty
+ ; let (args, _) = tcSplitFunTys ty
+ n_actual = length args
+ (env'', orig_ty') = tidyOpenType env' orig_tc_ty
+ ; return ( env''
+ , mk_fun_tys_msg orig_ty' ty n_actual arity herald) }
+ where
+ orig_tc_ty = checkingExpType "matchExpectedFunTys" orig_ty
+ -- this is safe b/c we're called from "go"
+
+-- Like 'matchExpectedFunTys', but used when you have an "actual" type,
+-- for example in function application
+matchActualFunTys :: SDoc -- See Note [Herald for matchExpectedFunTys]
+ -> CtOrigin
+ -> Maybe (HsExpr GhcRn) -- the thing with type TcSigmaType
+ -> Arity
+ -> TcSigmaType
+ -> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
+-- If matchActualFunTys n ty = (wrap, [t1,..,tn], ty_r)
+-- then wrap : ty ~> (t1 -> ... -> tn -> ty_r)
+matchActualFunTys herald ct_orig mb_thing arity ty
+ = matchActualFunTysPart herald ct_orig mb_thing arity ty [] arity
+
+-- | Variant of 'matchActualFunTys' that works when supplied only part
+-- (that is, to the right of some arrows) of the full function type
+matchActualFunTysPart :: SDoc -- See Note [Herald for matchExpectedFunTys]
+ -> CtOrigin
+ -> Maybe (HsExpr GhcRn) -- the thing with type TcSigmaType
+ -> Arity
+ -> TcSigmaType
+ -> [TcSigmaType] -- reversed args. See (*) below.
+ -> Arity -- overall arity of the function, for errs
+ -> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
+matchActualFunTysPart herald ct_orig mb_thing arity orig_ty
+ orig_old_args full_arity
+ = go arity orig_old_args orig_ty
+-- Does not allocate unnecessary meta variables: if the input already is
+-- a function, we just take it apart. Not only is this efficient,
+-- it's important for higher rank: the argument might be of form
+-- (forall a. ty) -> other
+-- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd
+-- hide the forall inside a meta-variable
+
+-- (*) Sometimes it's necessary to call matchActualFunTys with only part
+-- (that is, to the right of some arrows) of the type of the function in
+-- question. (See GHC.Tc.Gen.Expr.tcArgs.) This argument is the reversed list of
+-- arguments already seen (that is, not part of the TcSigmaType passed
+-- in elsewhere).
+
+ where
+ -- This function has a bizarre mechanic: it accumulates arguments on
+ -- the way down and also builds an argument list on the way up. Why:
+ -- 1. The returns args list and the accumulated args list might be different.
+ -- The accumulated args include all the arg types for the function,
+ -- including those from before this function was called. The returned
+ -- list should include only those arguments produced by this call of
+ -- matchActualFunTys
+ --
+ -- 2. The HsWrapper can be built only on the way up. It seems (more)
+ -- bizarre to build the HsWrapper but not the arg_tys.
+ --
+ -- Refactoring is welcome.
+ go :: Arity
+ -> [TcSigmaType] -- accumulator of arguments (reversed)
+ -> TcSigmaType -- the remainder of the type as we're processing
+ -> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
+ go 0 _ ty = return (idHsWrapper, [], ty)
+
+ go n acc_args ty
+ | not (null tvs && null theta)
+ = do { (wrap1, rho) <- topInstantiate ct_orig ty
+ ; (wrap2, arg_tys, res_ty) <- go n acc_args rho
+ ; return (wrap2 <.> wrap1, arg_tys, res_ty) }
+ where
+ (tvs, theta, _) = tcSplitSigmaTy ty
+
+ go n acc_args ty
+ | Just ty' <- tcView ty = go n acc_args ty'
+
+ go n acc_args (FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty })
+ = ASSERT( af == VisArg )
+ do { (wrap_res, tys, ty_r) <- go (n-1) (arg_ty : acc_args) res_ty
+ ; return ( mkWpFun idHsWrapper wrap_res arg_ty ty_r doc
+ , arg_ty : tys, ty_r ) }
+ where
+ doc = text "When inferring the argument type of a function with type" <+>
+ quotes (ppr orig_ty)
+
+ go n acc_args ty@(TyVarTy tv)
+ | isMetaTyVar tv
+ = do { cts <- readMetaTyVar tv
+ ; case cts of
+ Indirect ty' -> go n acc_args ty'
+ Flexi -> defer n ty }
+
+ -- In all other cases we bale out into ordinary unification
+ -- However unlike the meta-tyvar case, we are sure that the
+ -- number of arguments doesn't match arity of the original
+ -- type, so we can add a bit more context to the error message
+ -- (cf #7869).
+ --
+ -- It is not always an error, because specialized type may have
+ -- different arity, for example:
+ --
+ -- > f1 = f2 'a'
+ -- > f2 :: Monad m => m Bool
+ -- > f2 = undefined
+ --
+ -- But in that case we add specialized type into error context
+ -- anyway, because it may be useful. See also #9605.
+ go n acc_args ty = addErrCtxtM (mk_ctxt (reverse acc_args) ty) $
+ defer n ty
+
+ ------------
+ defer n fun_ty
+ = do { arg_tys <- replicateM n newOpenFlexiTyVarTy
+ ; res_ty <- newOpenFlexiTyVarTy
+ ; let unif_fun_ty = mkVisFunTys arg_tys res_ty
+ ; co <- unifyType mb_thing fun_ty unif_fun_ty
+ ; return (mkWpCastN co, arg_tys, res_ty) }
+
+ ------------
+ mk_ctxt :: [TcSigmaType] -> TcSigmaType -> TidyEnv -> TcM (TidyEnv, MsgDoc)
+ mk_ctxt arg_tys res_ty env
+ = do { let ty = mkVisFunTys arg_tys res_ty
+ ; (env1, zonked) <- zonkTidyTcType env ty
+ -- zonking might change # of args
+ ; let (zonked_args, _) = tcSplitFunTys zonked
+ n_actual = length zonked_args
+ (env2, unzonked) = tidyOpenType env1 ty
+ ; return ( env2
+ , mk_fun_tys_msg unzonked zonked n_actual full_arity herald) }
+
+mk_fun_tys_msg :: TcType -- the full type passed in (unzonked)
+ -> TcType -- the full type passed in (zonked)
+ -> Arity -- the # of args found
+ -> Arity -- the # of args wanted
+ -> SDoc -- overall herald
+ -> SDoc
+mk_fun_tys_msg full_ty ty n_args full_arity herald
+ = herald <+> speakNOf full_arity (text "argument") <> comma $$
+ if n_args == full_arity
+ then text "its type is" <+> quotes (pprType full_ty) <>
+ comma $$
+ text "it is specialized to" <+> quotes (pprType ty)
+ else sep [text "but its type" <+> quotes (pprType ty),
+ if n_args == 0 then text "has none"
+ else text "has only" <+> speakN n_args]
+
+----------------------
+matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType)
+-- Special case for lists
+matchExpectedListTy exp_ty
+ = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty
+ ; return (co, elt_ty) }
+
+---------------------
+matchExpectedTyConApp :: TyCon -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> *
+ -> TcRhoType -- orig_ty
+ -> TcM (TcCoercionN, -- T k1 k2 k3 a b c ~N orig_ty
+ [TcSigmaType]) -- Element types, k1 k2 k3 a b c
+
+-- It's used for wired-in tycons, so we call checkWiredInTyCon
+-- Precondition: never called with FunTyCon
+-- Precondition: input type :: *
+-- Postcondition: (T k1 k2 k3 a b c) is well-kinded
+
+matchExpectedTyConApp tc orig_ty
+ = ASSERT(tc /= funTyCon) go orig_ty
+ where
+ go ty
+ | Just ty' <- tcView ty
+ = go ty'
+
+ go ty@(TyConApp tycon args)
+ | tc == tycon -- Common case
+ = return (mkTcNomReflCo ty, args)
+
+ go (TyVarTy tv)
+ | isMetaTyVar tv
+ = do { cts <- readMetaTyVar tv
+ ; case cts of
+ Indirect ty -> go ty
+ Flexi -> defer }
+
+ go _ = defer
+
+ -- If the common case does not occur, instantiate a template
+ -- T k1 .. kn t1 .. tm, and unify with the original type
+ -- Doing it this way ensures that the types we return are
+ -- kind-compatible with T. For example, suppose we have
+ -- matchExpectedTyConApp T (f Maybe)
+ -- where data T a = MkT a
+ -- Then we don't want to instantiate T's data constructors with
+ -- (a::*) ~ Maybe
+ -- because that'll make types that are utterly ill-kinded.
+ -- This happened in #7368
+ defer
+ = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc)
+ ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs)
+ ; let args = mkTyVarTys arg_tvs
+ tc_template = mkTyConApp tc args
+ ; co <- unifyType Nothing tc_template orig_ty
+ ; return (co, args) }
+
+----------------------
+matchExpectedAppTy :: TcRhoType -- orig_ty
+ -> TcM (TcCoercion, -- m a ~N orig_ty
+ (TcSigmaType, TcSigmaType)) -- Returns m, a
+-- If the incoming type is a mutable type variable of kind k, then
+-- matchExpectedAppTy returns a new type variable (m: * -> k); note the *.
+
+matchExpectedAppTy orig_ty
+ = go orig_ty
+ where
+ go ty
+ | Just ty' <- tcView ty = go ty'
+
+ | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty
+ = return (mkTcNomReflCo orig_ty, (fun_ty, arg_ty))
+
+ go (TyVarTy tv)
+ | isMetaTyVar tv
+ = do { cts <- readMetaTyVar tv
+ ; case cts of
+ Indirect ty -> go ty
+ Flexi -> defer }
+
+ go _ = defer
+
+ -- Defer splitting by generating an equality constraint
+ defer
+ = do { ty1 <- newFlexiTyVarTy kind1
+ ; ty2 <- newFlexiTyVarTy kind2
+ ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty
+ ; return (co, (ty1, ty2)) }
+
+ orig_kind = tcTypeKind orig_ty
+ kind1 = mkVisFunTy liftedTypeKind orig_kind
+ kind2 = liftedTypeKind -- m :: * -> k
+ -- arg type :: *
+
+{-
+************************************************************************
+* *
+ Subsumption checking
+* *
+************************************************************************
+
+Note [Subsumption checking: tcSubType]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+All the tcSubType calls have the form
+ tcSubType actual_ty expected_ty
+which checks
+ actual_ty <= expected_ty
+
+That is, that a value of type actual_ty is acceptable in
+a place expecting a value of type expected_ty. I.e. that
+
+ actual ty is more polymorphic than expected_ty
+
+It returns a coercion function
+ co_fn :: actual_ty ~ expected_ty
+which takes an HsExpr of type actual_ty into one of type
+expected_ty.
+
+These functions do not actually check for subsumption. They check if
+expected_ty is an appropriate annotation to use for something of type
+actual_ty. This difference matters when thinking about visible type
+application. For example,
+
+ forall a. a -> forall b. b -> b
+ DOES NOT SUBSUME
+ forall a b. a -> b -> b
+
+because the type arguments appear in a different order. (Neither does
+it work the other way around.) BUT, these types are appropriate annotations
+for one another. Because the user directs annotations, it's OK if some
+arguments shuffle around -- after all, it's what the user wants.
+Bottom line: none of this changes with visible type application.
+
+There are a number of wrinkles (below).
+
+Notice that Wrinkle 1 and 2 both require eta-expansion, which technically
+may increase termination. We just put up with this, in exchange for getting
+more predictable type inference.
+
+Wrinkle 1: Note [Deep skolemisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want (forall a. Int -> a -> a) <= (Int -> forall a. a->a)
+(see section 4.6 of "Practical type inference for higher rank types")
+So we must deeply-skolemise the RHS before we instantiate the LHS.
+
+That is why tc_sub_type starts with a call to tcSkolemise (which does the
+deep skolemisation), and then calls the DS variant (which assumes
+that expected_ty is deeply skolemised)
+
+Wrinkle 2: Note [Co/contra-variance of subsumption checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider g :: (Int -> Int) -> Int
+ f1 :: (forall a. a -> a) -> Int
+ f1 = g
+
+ f2 :: (forall a. a -> a) -> Int
+ f2 x = g x
+f2 will typecheck, and it would be odd/fragile if f1 did not.
+But f1 will only typecheck if we have that
+ (Int->Int) -> Int <= (forall a. a->a) -> Int
+And that is only true if we do the full co/contravariant thing
+in the subsumption check. That happens in the FunTy case of
+tcSubTypeDS_NC_O, and is the sole reason for the WpFun form of
+HsWrapper.
+
+Another powerful reason for doing this co/contra stuff is visible
+in #9569, involving instantiation of constraint variables,
+and again involving eta-expansion.
+
+Wrinkle 3: Note [Higher rank types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider tc150:
+ f y = \ (x::forall a. a->a). blah
+The following happens:
+* We will infer the type of the RHS, ie with a res_ty = alpha.
+* Then the lambda will split alpha := beta -> gamma.
+* And then we'll check tcSubType IsSwapped beta (forall a. a->a)
+
+So it's important that we unify beta := forall a. a->a, rather than
+skolemising the type.
+-}
+
+
+-- | Call this variant when you are in a higher-rank situation and
+-- you know the right-hand type is deeply skolemised.
+tcSubTypeHR :: CtOrigin -- ^ of the actual type
+ -> Maybe (HsExpr GhcRn) -- ^ If present, it has type ty_actual
+ -> TcSigmaType -> ExpRhoType -> TcM HsWrapper
+tcSubTypeHR orig = tcSubTypeDS_NC_O orig GenSigCtxt
+
+------------------------
+tcSubTypeET :: CtOrigin -> UserTypeCtxt
+ -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
+-- If wrap = tc_sub_type_et t1 t2
+-- => wrap :: t1 ~> t2
+tcSubTypeET orig ctxt (Check ty_actual) ty_expected
+ = tc_sub_tc_type eq_orig orig ctxt ty_actual ty_expected
+ where
+ eq_orig = TypeEqOrigin { uo_actual = ty_expected
+ , uo_expected = ty_actual
+ , uo_thing = Nothing
+ , uo_visible = True }
+
+tcSubTypeET _ _ (Infer inf_res) ty_expected
+ = ASSERT2( not (ir_inst inf_res), ppr inf_res $$ ppr ty_expected )
+ -- An (Infer inf_res) ExpSigmaType passed into tcSubTypeET never
+ -- has the ir_inst field set. Reason: in patterns (which is what
+ -- tcSubTypeET is used for) do not aggressively instantiate
+ do { co <- fill_infer_result ty_expected inf_res
+ -- Since ir_inst is false, we can skip fillInferResult
+ -- and go straight to fill_infer_result
+
+ ; return (mkWpCastN (mkTcSymCo co)) }
+
+------------------------
+tcSubTypeO :: CtOrigin -- ^ of the actual type
+ -> UserTypeCtxt -- ^ of the expected type
+ -> TcSigmaType
+ -> ExpRhoType
+ -> TcM HsWrapper
+tcSubTypeO orig ctxt ty_actual ty_expected
+ = addSubTypeCtxt ty_actual ty_expected $
+ do { traceTc "tcSubTypeDS_O" (vcat [ pprCtOrigin orig
+ , pprUserTypeCtxt ctxt
+ , ppr ty_actual
+ , ppr ty_expected ])
+ ; tcSubTypeDS_NC_O orig ctxt Nothing ty_actual ty_expected }
+
+addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a
+addSubTypeCtxt ty_actual ty_expected thing_inside
+ | isRhoTy ty_actual -- If there is no polymorphism involved, the
+ , isRhoExpTy ty_expected -- TypeEqOrigin stuff (added by the _NC functions)
+ = thing_inside -- gives enough context by itself
+ | otherwise
+ = addErrCtxtM mk_msg thing_inside
+ where
+ mk_msg tidy_env
+ = do { (tidy_env, ty_actual) <- zonkTidyTcType tidy_env ty_actual
+ -- might not be filled if we're debugging. ugh.
+ ; mb_ty_expected <- readExpType_maybe ty_expected
+ ; (tidy_env, ty_expected) <- case mb_ty_expected of
+ Just ty -> second mkCheckExpType <$>
+ zonkTidyTcType tidy_env ty
+ Nothing -> return (tidy_env, ty_expected)
+ ; ty_expected <- readExpType ty_expected
+ ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected
+ ; let msg = vcat [ hang (text "When checking that:")
+ 4 (ppr ty_actual)
+ , nest 2 (hang (text "is more polymorphic than:")
+ 2 (ppr ty_expected)) ]
+ ; return (tidy_env, msg) }
+
+---------------
+-- The "_NC" variants do not add a typechecker-error context;
+-- the caller is assumed to do that
+
+tcSubType_NC :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper
+-- Checks that actual <= expected
+-- Returns HsWrapper :: actual ~ expected
+tcSubType_NC ctxt ty_actual ty_expected
+ = do { traceTc "tcSubType_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected])
+ ; tc_sub_tc_type origin origin ctxt ty_actual ty_expected }
+ where
+ origin = TypeEqOrigin { uo_actual = ty_actual
+ , uo_expected = ty_expected
+ , uo_thing = Nothing
+ , uo_visible = True }
+
+tcSubTypeDS :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> ExpRhoType -> TcM HsWrapper
+-- Just like tcSubType, but with the additional precondition that
+-- ty_expected is deeply skolemised (hence "DS")
+tcSubTypeDS orig ctxt ty_actual ty_expected
+ = addSubTypeCtxt ty_actual ty_expected $
+ do { traceTc "tcSubTypeDS_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected])
+ ; tcSubTypeDS_NC_O orig ctxt Nothing ty_actual ty_expected }
+
+tcSubTypeDS_NC_O :: CtOrigin -- origin used for instantiation only
+ -> UserTypeCtxt
+ -> Maybe (HsExpr GhcRn)
+ -> TcSigmaType -> ExpRhoType -> TcM HsWrapper
+-- Just like tcSubType, but with the additional precondition that
+-- ty_expected is deeply skolemised
+tcSubTypeDS_NC_O inst_orig ctxt m_thing ty_actual ty_expected
+ = case ty_expected of
+ Infer inf_res -> fillInferResult inst_orig ty_actual inf_res
+ Check ty -> tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty
+ where
+ eq_orig = TypeEqOrigin { uo_actual = ty_actual, uo_expected = ty
+ , uo_thing = ppr <$> m_thing
+ , uo_visible = True }
+
+---------------
+tc_sub_tc_type :: CtOrigin -- used when calling uType
+ -> CtOrigin -- used when instantiating
+ -> UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper
+-- If wrap = tc_sub_type t1 t2
+-- => wrap :: t1 ~> t2
+tc_sub_tc_type eq_orig inst_orig ctxt ty_actual ty_expected
+ | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily]
+ , not (possibly_poly ty_actual)
+ = do { traceTc "tc_sub_tc_type (drop to equality)" $
+ vcat [ text "ty_actual =" <+> ppr ty_actual
+ , text "ty_expected =" <+> ppr ty_expected ]
+ ; mkWpCastN <$>
+ uType TypeLevel eq_orig ty_actual ty_expected }
+
+ | otherwise -- This is the general case
+ = do { traceTc "tc_sub_tc_type (general case)" $
+ vcat [ text "ty_actual =" <+> ppr ty_actual
+ , text "ty_expected =" <+> ppr ty_expected ]
+ ; (sk_wrap, inner_wrap) <- tcSkolemise ctxt ty_expected $
+ \ _ sk_rho ->
+ tc_sub_type_ds eq_orig inst_orig ctxt
+ ty_actual sk_rho
+ ; return (sk_wrap <.> inner_wrap) }
+ where
+ possibly_poly ty
+ | isForAllTy ty = True
+ | Just (_, res) <- splitFunTy_maybe ty = possibly_poly res
+ | otherwise = False
+ -- NB *not* tcSplitFunTy, because here we want
+ -- to decompose type-class arguments too
+
+ definitely_poly ty
+ | (tvs, theta, tau) <- tcSplitSigmaTy ty
+ , (tv:_) <- tvs
+ , null theta
+ , isInsolubleOccursCheck NomEq tv tau
+ = True
+ | otherwise
+ = False
+
+{- Note [Don't skolemise unnecessarily]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are trying to solve
+ (Char->Char) <= (forall a. a->a)
+We could skolemise the 'forall a', and then complain
+that (Char ~ a) is insoluble; but that's a pretty obscure
+error. It's better to say that
+ (Char->Char) ~ (forall a. a->a)
+fails.
+
+So roughly:
+ * if the ty_expected has an outermost forall
+ (i.e. skolemisation is the next thing we'd do)
+ * and the ty_actual has no top-level polymorphism (but looking deeply)
+then we can revert to simple equality. But we need to be careful.
+These examples are all fine:
+
+ * (Char -> forall a. a->a) <= (forall a. Char -> a -> a)
+ Polymorphism is buried in ty_actual
+
+ * (Char->Char) <= (forall a. Char -> Char)
+ ty_expected isn't really polymorphic
+
+ * (Char->Char) <= (forall a. (a~Char) => a -> a)
+ ty_expected isn't really polymorphic
+
+ * (Char->Char) <= (forall a. F [a] Char -> Char)
+ where type instance F [x] t = t
+ ty_expected isn't really polymorphic
+
+If we prematurely go to equality we'll reject a program we should
+accept (e.g. #13752). So the test (which is only to improve
+error message) is very conservative:
+ * ty_actual is /definitely/ monomorphic
+ * ty_expected is /definitely/ polymorphic
+-}
+
+---------------
+tc_sub_type_ds :: CtOrigin -- used when calling uType
+ -> CtOrigin -- used when instantiating
+ -> UserTypeCtxt -> TcSigmaType -> TcRhoType -> TcM HsWrapper
+-- If wrap = tc_sub_type_ds t1 t2
+-- => wrap :: t1 ~> t2
+-- Here is where the work actually happens!
+-- Precondition: ty_expected is deeply skolemised
+tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected
+ = do { traceTc "tc_sub_type_ds" $
+ vcat [ text "ty_actual =" <+> ppr ty_actual
+ , text "ty_expected =" <+> ppr ty_expected ]
+ ; go ty_actual ty_expected }
+ where
+ go ty_a ty_e | Just ty_a' <- tcView ty_a = go ty_a' ty_e
+ | Just ty_e' <- tcView ty_e = go ty_a ty_e'
+
+ go (TyVarTy tv_a) ty_e
+ = do { lookup_res <- lookupTcTyVar tv_a
+ ; case lookup_res of
+ Filled ty_a' ->
+ do { traceTc "tcSubTypeDS_NC_O following filled act meta-tyvar:"
+ (ppr tv_a <+> text "-->" <+> ppr ty_a')
+ ; tc_sub_type_ds eq_orig inst_orig ctxt ty_a' ty_e }
+ Unfilled _ -> unify }
+
+ -- Historical note (Sept 16): there was a case here for
+ -- go ty_a (TyVarTy alpha)
+ -- which, in the impredicative case unified alpha := ty_a
+ -- where th_a is a polytype. Not only is this probably bogus (we
+ -- simply do not have decent story for impredicative types), but it
+ -- caused #12616 because (also bizarrely) 'deriving' code had
+ -- -XImpredicativeTypes on. I deleted the entire case.
+
+ go (FunTy { ft_af = VisArg, ft_arg = act_arg, ft_res = act_res })
+ (FunTy { ft_af = VisArg, ft_arg = exp_arg, ft_res = exp_res })
+ = -- See Note [Co/contra-variance of subsumption checking]
+ do { res_wrap <- tc_sub_type_ds eq_orig inst_orig ctxt act_res exp_res
+ ; arg_wrap <- tc_sub_tc_type eq_orig given_orig GenSigCtxt exp_arg act_arg
+ -- GenSigCtxt: See Note [Setting the argument context]
+ ; return (mkWpFun arg_wrap res_wrap exp_arg exp_res doc) }
+ -- arg_wrap :: exp_arg ~> act_arg
+ -- res_wrap :: act-res ~> exp_res
+ where
+ given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg [])
+ doc = text "When checking that" <+> quotes (ppr ty_actual) <+>
+ text "is more polymorphic than" <+> quotes (ppr ty_expected)
+
+ go ty_a ty_e
+ | let (tvs, theta, _) = tcSplitSigmaTy ty_a
+ , not (null tvs && null theta)
+ = do { (in_wrap, in_rho) <- topInstantiate inst_orig ty_a
+ ; body_wrap <- tc_sub_type_ds
+ (eq_orig { uo_actual = in_rho
+ , uo_expected = ty_expected })
+ inst_orig ctxt in_rho ty_e
+ ; return (body_wrap <.> in_wrap) }
+
+ | otherwise -- Revert to unification
+ = inst_and_unify
+ -- It's still possible that ty_actual has nested foralls. Instantiate
+ -- these, as there's no way unification will succeed with them in.
+ -- See typecheck/should_compile/T11305 for an example of when this
+ -- is important. The problem is that we're checking something like
+ -- a -> forall b. b -> b <= alpha beta gamma
+ -- where we end up with alpha := (->)
+
+ inst_and_unify = do { (wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual
+
+ -- If we haven't recurred through an arrow, then
+ -- the eq_orig will list ty_actual. In this case,
+ -- we want to update the origin to reflect the
+ -- instantiation. If we *have* recurred through
+ -- an arrow, it's better not to update.
+ ; let eq_orig' = case eq_orig of
+ TypeEqOrigin { uo_actual = orig_ty_actual }
+ | orig_ty_actual `tcEqType` ty_actual
+ , not (isIdHsWrapper wrap)
+ -> eq_orig { uo_actual = rho_a }
+ _ -> eq_orig
+
+ ; cow <- uType TypeLevel eq_orig' rho_a ty_expected
+ ; return (mkWpCastN cow <.> wrap) }
+
+
+ -- use versions without synonyms expanded
+ unify = mkWpCastN <$> uType TypeLevel eq_orig ty_actual ty_expected
+
+{- Note [Settting the argument context]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider we are doing the ambiguity check for the (bogus)
+ f :: (forall a b. C b => a -> a) -> Int
+
+We'll call
+ tcSubType ((forall a b. C b => a->a) -> Int )
+ ((forall a b. C b => a->a) -> Int )
+
+with a UserTypeCtxt of (FunSigCtxt "f"). Then we'll do the co/contra thing
+on the argument type of the (->) -- and at that point we want to switch
+to a UserTypeCtxt of GenSigCtxt. Why?
+
+* Error messages. If we stick with FunSigCtxt we get errors like
+ * Could not deduce: C b
+ from the context: C b0
+ bound by the type signature for:
+ f :: forall a b. C b => a->a
+ But of course f does not have that type signature!
+ Example tests: T10508, T7220a, Simple14
+
+* Implications. We may decide to build an implication for the whole
+ ambiguity check, but we don't need one for each level within it,
+ and GHC.Tc.Utils.Unify.alwaysBuildImplication checks the UserTypeCtxt.
+ See Note [When to build an implication]
+-}
+
+-----------------
+-- needs both un-type-checked (for origins) and type-checked (for wrapping)
+-- expressions
+tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType
+ -> TcM (HsExpr GhcTcId)
+tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr
+
+-- | Sometimes we don't have a @HsExpr Name@ to hand, and this is more
+-- convenient.
+tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType
+ -> TcM (HsExpr GhcTcId)
+tcWrapResultO orig rn_expr expr actual_ty res_ty
+ = do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty
+ , text "Expected:" <+> ppr res_ty ])
+ ; cow <- tcSubTypeDS_NC_O orig GenSigCtxt
+ (Just rn_expr) actual_ty res_ty
+ ; return (mkHsWrap cow expr) }
+
+
+{- **********************************************************************
+%* *
+ ExpType functions: tcInfer, fillInferResult
+%* *
+%********************************************************************* -}
+
+-- | Infer a type using a fresh ExpType
+-- See also Note [ExpType] in GHC.Tc.Utils.TcMType
+-- Does not attempt to instantiate the inferred type
+tcInferNoInst :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
+tcInferNoInst = tcInfer False
+
+tcInferInst :: (ExpRhoType -> TcM a) -> TcM (a, TcRhoType)
+tcInferInst = tcInfer True
+
+tcInfer :: Bool -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
+tcInfer instantiate tc_check
+ = do { res_ty <- newInferExpType instantiate
+ ; result <- tc_check res_ty
+ ; res_ty <- readExpType res_ty
+ ; return (result, res_ty) }
+
+fillInferResult :: CtOrigin -> TcType -> InferResult -> TcM HsWrapper
+-- If wrap = fillInferResult t1 t2
+-- => wrap :: t1 ~> t2
+-- See Note [Deep instantiation of InferResult]
+fillInferResult orig ty inf_res@(IR { ir_inst = instantiate_me })
+ | instantiate_me
+ = do { (wrap, rho) <- deeplyInstantiate orig ty
+ ; co <- fill_infer_result rho inf_res
+ ; return (mkWpCastN co <.> wrap) }
+
+ | otherwise
+ = do { co <- fill_infer_result ty inf_res
+ ; return (mkWpCastN co) }
+
+fill_infer_result :: TcType -> InferResult -> TcM TcCoercionN
+-- If wrap = fill_infer_result t1 t2
+-- => wrap :: t1 ~> t2
+fill_infer_result orig_ty (IR { ir_uniq = u, ir_lvl = res_lvl
+ , ir_ref = ref })
+ = do { (ty_co, ty_to_fill_with) <- promoteTcType res_lvl orig_ty
+
+ ; traceTc "Filling ExpType" $
+ ppr u <+> text ":=" <+> ppr ty_to_fill_with
+
+ ; when debugIsOn (check_hole ty_to_fill_with)
+
+ ; writeTcRef ref (Just ty_to_fill_with)
+
+ ; return ty_co }
+ where
+ check_hole ty -- Debug check only
+ = do { let ty_lvl = tcTypeLevel ty
+ ; MASSERT2( not (ty_lvl `strictlyDeeperThan` res_lvl),
+ ppr u $$ ppr res_lvl $$ ppr ty_lvl $$
+ ppr ty <+> dcolon <+> ppr (tcTypeKind ty) $$ ppr orig_ty )
+ ; cts <- readTcRef ref
+ ; case cts of
+ Just already_there -> pprPanic "writeExpType"
+ (vcat [ ppr u
+ , ppr ty
+ , ppr already_there ])
+ Nothing -> return () }
+
+{- Note [Deep instantiation of InferResult]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In some cases we want to deeply instantiate before filling in
+an InferResult, and in some cases not. That's why InferReult
+has the ir_inst flag.
+
+ir_inst = True: deeply instantiate
+----------------------------------
+
+1. Consider
+ f x = (*)
+ We want to instantiate the type of (*) before returning, else we
+ will infer the type
+ f :: forall {a}. a -> forall b. Num b => b -> b -> b
+ This is surely confusing for users.
+
+ And worse, the monomorphism restriction won't work properly. The MR is
+ dealt with in simplifyInfer, and simplifyInfer has no way of
+ instantiating. This could perhaps be worked around, but it may be
+ hard to know even when instantiation should happen.
+
+2. Another reason. Consider
+ f :: (?x :: Int) => a -> a
+ g y = let ?x = 3::Int in f
+ Here want to instantiate f's type so that the ?x::Int constraint
+ gets discharged by the enclosing implicit-parameter binding.
+
+ir_inst = False: do not instantiate
+-----------------------------------
+
+1. Consider this (which uses visible type application):
+
+ (let { f :: forall a. a -> a; f x = x } in f) @Int
+
+ We'll call GHC.Tc.Gen.Expr.tcInferFun to infer the type of the (let .. in f)
+ And we don't want to instantiate the type of 'f' when we reach it,
+ else the outer visible type application won't work
+
+2. :type +v. When we say
+
+ :type +v const @Int
+
+ we really want `forall b. Int -> b -> Int`. Note that this is *not*
+ instantiated.
+
+3. Pattern bindings. For example:
+
+ foo x
+ | blah <- const @Int
+ = (blah x False, blah x 'z')
+
+ Note that `blah` is polymorphic. (This isn't a terribly compelling
+ reason, but the choice of ir_inst does matter here.)
+
+Discussion
+----------
+We thought that we should just remove the ir_inst flag, in favor of
+always instantiating. Essentially: motivations (1) and (3) for ir_inst = False
+are not terribly exciting. However, motivation (2) is quite important.
+Furthermore, there really was not much of a simplification of the code
+in removing ir_inst, and working around it to enable flows like what we
+see in (2) is annoying. This was done in #17173.
+
+-}
+
+{- *********************************************************************
+* *
+ Promoting types
+* *
+********************************************************************* -}
+
+promoteTcType :: TcLevel -> TcType -> TcM (TcCoercion, TcType)
+-- See Note [Promoting a type]
+-- promoteTcType level ty = (co, ty')
+-- * Returns ty' whose max level is just 'level'
+-- and whose kind is ~# to the kind of 'ty'
+-- and whose kind has form TYPE rr
+-- * and co :: ty ~ ty'
+-- * and emits constraints to justify the coercion
+promoteTcType dest_lvl ty
+ = do { cur_lvl <- getTcLevel
+ ; if (cur_lvl `sameDepthAs` dest_lvl)
+ then dont_promote_it
+ else promote_it }
+ where
+ promote_it :: TcM (TcCoercion, TcType)
+ promote_it -- Emit a constraint (alpha :: TYPE rr) ~ ty
+ -- where alpha and rr are fresh and from level dest_lvl
+ = do { rr <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy
+ ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (tYPE rr)
+ ; let eq_orig = TypeEqOrigin { uo_actual = ty
+ , uo_expected = prom_ty
+ , uo_thing = Nothing
+ , uo_visible = False }
+
+ ; co <- emitWantedEq eq_orig TypeLevel Nominal ty prom_ty
+ ; return (co, prom_ty) }
+
+ dont_promote_it :: TcM (TcCoercion, TcType)
+ dont_promote_it -- Check that ty :: TYPE rr, for some (fresh) rr
+ = do { res_kind <- newOpenTypeKind
+ ; let ty_kind = tcTypeKind ty
+ kind_orig = TypeEqOrigin { uo_actual = ty_kind
+ , uo_expected = res_kind
+ , uo_thing = Nothing
+ , uo_visible = False }
+ ; ki_co <- uType KindLevel kind_orig (tcTypeKind ty) res_kind
+ ; let co = mkTcGReflRightCo Nominal ty ki_co
+ ; return (co, ty `mkCastTy` ki_co) }
+
+{- Note [Promoting a type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#12427)
+
+ data T where
+ MkT :: (Int -> Int) -> a -> T
+
+ h y = case y of MkT v w -> v
+
+We'll infer the RHS type with an expected type ExpType of
+ (IR { ir_lvl = l, ir_ref = ref, ... )
+where 'l' is the TcLevel of the RHS of 'h'. Then the MkT pattern
+match will increase the level, so we'll end up in tcSubType, trying to
+unify the type of v,
+ v :: Int -> Int
+with the expected type. But this attempt takes place at level (l+1),
+rightly so, since v's type could have mentioned existential variables,
+(like w's does) and we want to catch that.
+
+So we
+ - create a new meta-var alpha[l+1]
+ - fill in the InferRes ref cell 'ref' with alpha
+ - emit an equality constraint, thus
+ [W] alpha[l+1] ~ (Int -> Int)
+
+That constraint will float outwards, as it should, unless v's
+type mentions a skolem-captured variable.
+
+This approach fails if v has a higher rank type; see
+Note [Promotion and higher rank types]
+
+
+Note [Promotion and higher rank types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If v had a higher-rank type, say v :: (forall a. a->a) -> Int,
+then we'd emit an equality
+ [W] alpha[l+1] ~ ((forall a. a->a) -> Int)
+which will sadly fail because we can't unify a unification variable
+with a polytype. But there is nothing really wrong with the program
+here.
+
+We could just about solve this by "promote the type" of v, to expose
+its polymorphic "shape" while still leaving constraints that will
+prevent existential escape. But we must be careful! Exposing
+the "shape" of the type is precisely what we must NOT do under
+a GADT pattern match! So in this case we might promote the type
+to
+ (forall a. a->a) -> alpha[l+1]
+and emit the constraint
+ [W] alpha[l+1] ~ Int
+Now the promoted type can fill the ref cell, while the emitted
+equality can float or not, according to the usual rules.
+
+But that's not quite right! We are exposing the arrow! We could
+deal with that too:
+ (forall a. mu[l+1] a a) -> alpha[l+1]
+with constraints
+ [W] alpha[l+1] ~ Int
+ [W] mu[l+1] ~ (->)
+Here we abstract over the '->' inside the forall, in case that
+is subject to an equality constraint from a GADT match.
+
+Note that we kept the outer (->) because that's part of
+the polymorphic "shape". And because of impredicativity,
+GADT matches can't give equalities that affect polymorphic
+shape.
+
+This reasoning just seems too complicated, so I decided not
+to do it. These higher-rank notes are just here to record
+the thinking.
+-}
+
+{- *********************************************************************
+* *
+ Generalisation
+* *
+********************************************************************* -}
+
+-- | Take an "expected type" and strip off quantifiers to expose the
+-- type underneath, binding the new skolems for the @thing_inside@.
+-- The returned 'HsWrapper' has type @specific_ty -> expected_ty@.
+tcSkolemise :: UserTypeCtxt -> TcSigmaType
+ -> ([TcTyVar] -> TcType -> TcM result)
+ -- ^ These are only ever used for scoped type variables.
+ -> TcM (HsWrapper, result)
+ -- ^ The expression has type: spec_ty -> expected_ty
+
+tcSkolemise ctxt expected_ty thing_inside
+ -- We expect expected_ty to be a forall-type
+ -- If not, the call is a no-op
+ = do { traceTc "tcSkolemise" Outputable.empty
+ ; (wrap, tv_prs, given, rho') <- deeplySkolemise expected_ty
+
+ ; lvl <- getTcLevel
+ ; when debugIsOn $
+ traceTc "tcSkolemise" $ vcat [
+ ppr lvl,
+ text "expected_ty" <+> ppr expected_ty,
+ text "inst tyvars" <+> ppr tv_prs,
+ text "given" <+> ppr given,
+ text "inst type" <+> ppr rho' ]
+
+ -- Generally we must check that the "forall_tvs" haven't been constrained
+ -- The interesting bit here is that we must include the free variables
+ -- of the expected_ty. Here's an example:
+ -- runST (newVar True)
+ -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
+ -- for (newVar True), with s fresh. Then we unify with the runST's arg type
+ -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
+ -- So now s' isn't unconstrained because it's linked to a.
+ --
+ -- However [Oct 10] now that the untouchables are a range of
+ -- TcTyVars, all this is handled automatically with no need for
+ -- extra faffing around
+
+ ; let tvs' = map snd tv_prs
+ skol_info = SigSkol ctxt expected_ty tv_prs
+
+ ; (ev_binds, result) <- checkConstraints skol_info tvs' given $
+ thing_inside tvs' rho'
+
+ ; return (wrap <.> mkWpLet ev_binds, result) }
+ -- The ev_binds returned by checkConstraints is very
+ -- often empty, in which case mkWpLet is a no-op
+
+-- | Variant of 'tcSkolemise' that takes an ExpType
+tcSkolemiseET :: UserTypeCtxt -> ExpSigmaType
+ -> (ExpRhoType -> TcM result)
+ -> TcM (HsWrapper, result)
+tcSkolemiseET _ et@(Infer {}) thing_inside
+ = (idHsWrapper, ) <$> thing_inside et
+tcSkolemiseET ctxt (Check ty) thing_inside
+ = tcSkolemise ctxt ty $ \_ -> thing_inside . mkCheckExpType
+
+checkConstraints :: SkolemInfo
+ -> [TcTyVar] -- Skolems
+ -> [EvVar] -- Given
+ -> TcM result
+ -> TcM (TcEvBinds, result)
+
+checkConstraints skol_info skol_tvs given thing_inside
+ = do { implication_needed <- implicationNeeded skol_info skol_tvs given
+
+ ; if implication_needed
+ then do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside
+ ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted
+ ; traceTc "checkConstraints" (ppr tclvl $$ ppr skol_tvs)
+ ; emitImplications implics
+ ; return (ev_binds, result) }
+
+ else -- Fast path. We check every function argument with
+ -- tcPolyExpr, which uses tcSkolemise and hence checkConstraints.
+ -- So this fast path is well-exercised
+ do { res <- thing_inside
+ ; return (emptyTcEvBinds, res) } }
+
+checkTvConstraints :: SkolemInfo
+ -> [TcTyVar] -- Skolem tyvars
+ -> TcM result
+ -> TcM result
+
+checkTvConstraints skol_info skol_tvs thing_inside
+ = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside
+ ; emitResidualTvConstraint skol_info Nothing skol_tvs tclvl wanted
+ ; return result }
+
+emitResidualTvConstraint :: SkolemInfo -> Maybe SDoc -> [TcTyVar]
+ -> TcLevel -> WantedConstraints -> TcM ()
+emitResidualTvConstraint skol_info m_telescope skol_tvs tclvl wanted
+ | isEmptyWC wanted
+ , isNothing m_telescope || skol_tvs `lengthAtMost` 1
+ -- If m_telescope is (Just d), we must do the bad-telescope check,
+ -- so we must /not/ discard the implication even if there are no
+ -- wanted constraints. See Note [Checking telescopes] in GHC.Tc.Types.Constraint.
+ -- Lacking this check led to #16247
+ = return ()
+
+ | otherwise
+ = do { ev_binds <- newNoTcEvBinds
+ ; implic <- newImplication
+ ; let status | insolubleWC wanted = IC_Insoluble
+ | otherwise = IC_Unsolved
+ -- If the inner constraints are insoluble,
+ -- we should mark the outer one similarly,
+ -- so that insolubleWC works on the outer one
+
+ ; emitImplication $
+ implic { ic_status = status
+ , ic_tclvl = tclvl
+ , ic_skols = skol_tvs
+ , ic_no_eqs = True
+ , ic_telescope = m_telescope
+ , ic_wanted = wanted
+ , ic_binds = ev_binds
+ , ic_info = skol_info } }
+
+implicationNeeded :: SkolemInfo -> [TcTyVar] -> [EvVar] -> TcM Bool
+-- See Note [When to build an implication]
+implicationNeeded skol_info skol_tvs given
+ | null skol_tvs
+ , null given
+ , not (alwaysBuildImplication skol_info)
+ = -- Empty skolems and givens
+ do { tc_lvl <- getTcLevel
+ ; if not (isTopTcLevel tc_lvl) -- No implication needed if we are
+ then return False -- already inside an implication
+ else
+ do { dflags <- getDynFlags -- If any deferral can happen,
+ -- we must build an implication
+ ; return (gopt Opt_DeferTypeErrors dflags ||
+ gopt Opt_DeferTypedHoles dflags ||
+ gopt Opt_DeferOutOfScopeVariables dflags) } }
+
+ | otherwise -- Non-empty skolems or givens
+ = return True -- Definitely need an implication
+
+alwaysBuildImplication :: SkolemInfo -> Bool
+-- See Note [When to build an implication]
+alwaysBuildImplication _ = False
+
+{- Commmented out for now while I figure out about error messages.
+ See #14185
+
+alwaysBuildImplication (SigSkol ctxt _ _)
+ = case ctxt of
+ FunSigCtxt {} -> True -- RHS of a binding with a signature
+ _ -> False
+alwaysBuildImplication (RuleSkol {}) = True
+alwaysBuildImplication (InstSkol {}) = True
+alwaysBuildImplication (FamInstSkol {}) = True
+alwaysBuildImplication _ = False
+-}
+
+buildImplicationFor :: TcLevel -> SkolemInfo -> [TcTyVar]
+ -> [EvVar] -> WantedConstraints
+ -> TcM (Bag Implication, TcEvBinds)
+buildImplicationFor tclvl skol_info skol_tvs given wanted
+ | isEmptyWC wanted && null given
+ -- Optimisation : if there are no wanteds, and no givens
+ -- don't generate an implication at all.
+ -- Reason for the (null given): we don't want to lose
+ -- the "inaccessible alternative" error check
+ = return (emptyBag, emptyTcEvBinds)
+
+ | otherwise
+ = ASSERT2( all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs, ppr skol_tvs )
+ -- Why allow TyVarTvs? Because implicitly declared kind variables in
+ -- non-CUSK type declarations are TyVarTvs, and we need to bring them
+ -- into scope as a skolem in an implication. This is OK, though,
+ -- because TyVarTvs will always remain tyvars, even after unification.
+ do { ev_binds_var <- newTcEvBinds
+ ; implic <- newImplication
+ ; let implic' = implic { ic_tclvl = tclvl
+ , ic_skols = skol_tvs
+ , ic_given = given
+ , ic_wanted = wanted
+ , ic_binds = ev_binds_var
+ , ic_info = skol_info }
+
+ ; return (unitBag implic', TcEvBinds ev_binds_var) }
+
+{- Note [When to build an implication]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have some 'skolems' and some 'givens', and we are
+considering whether to wrap the constraints in their scope into an
+implication. We must /always/ so if either 'skolems' or 'givens' are
+non-empty. But what if both are empty? You might think we could
+always drop the implication. Other things being equal, the fewer
+implications the better. Less clutter and overhead. But we must
+take care:
+
+* If we have an unsolved [W] g :: a ~# b, and -fdefer-type-errors,
+ we'll make a /term-level/ evidence binding for 'g = error "blah"'.
+ We must have an EvBindsVar those bindings!, otherwise they end up as
+ top-level unlifted bindings, which are verboten. This only matters
+ at top level, so we check for that
+ See also Note [Deferred errors for coercion holes] in GHC.Tc.Errors.
+ cf #14149 for an example of what goes wrong.
+
+* If you have
+ f :: Int; f = f_blah
+ g :: Bool; g = g_blah
+ If we don't build an implication for f or g (no tyvars, no givens),
+ the constraints for f_blah and g_blah are solved together. And that
+ can yield /very/ confusing error messages, because we can get
+ [W] C Int b1 -- from f_blah
+ [W] C Int b2 -- from g_blan
+ and fundpes can yield [D] b1 ~ b2, even though the two functions have
+ literally nothing to do with each other. #14185 is an example.
+ Building an implication keeps them separage.
+-}
+
+{-
+************************************************************************
+* *
+ Boxy unification
+* *
+************************************************************************
+
+The exported functions are all defined as versions of some
+non-exported generic functions.
+-}
+
+unifyType :: Maybe (HsExpr GhcRn) -- ^ If present, has type 'ty1'
+ -> TcTauType -> TcTauType -> TcM TcCoercionN
+-- Actual and expected types
+-- Returns a coercion : ty1 ~ ty2
+unifyType thing ty1 ty2 = traceTc "utype" (ppr ty1 $$ ppr ty2 $$ ppr thing) >>
+ uType TypeLevel origin ty1 ty2
+ where
+ origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2
+ , uo_thing = ppr <$> thing
+ , uo_visible = True } -- always called from a visible context
+
+unifyKind :: Maybe (HsType GhcRn) -> TcKind -> TcKind -> TcM CoercionN
+unifyKind thing ty1 ty2 = traceTc "ukind" (ppr ty1 $$ ppr ty2 $$ ppr thing) >>
+ uType KindLevel origin ty1 ty2
+ where origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2
+ , uo_thing = ppr <$> thing
+ , uo_visible = True } -- also always from a visible context
+
+---------------
+
+{-
+%************************************************************************
+%* *
+ uType and friends
+%* *
+%************************************************************************
+
+uType is the heart of the unifier.
+-}
+
+uType, uType_defer
+ :: TypeOrKind
+ -> CtOrigin
+ -> TcType -- ty1 is the *actual* type
+ -> TcType -- ty2 is the *expected* type
+ -> TcM CoercionN
+
+--------------
+-- It is always safe to defer unification to the main constraint solver
+-- See Note [Deferred unification]
+uType_defer t_or_k origin ty1 ty2
+ = do { co <- emitWantedEq origin t_or_k Nominal ty1 ty2
+
+ -- Error trace only
+ -- NB. do *not* call mkErrInfo unless tracing is on,
+ -- because it is hugely expensive (#5631)
+ ; whenDOptM Opt_D_dump_tc_trace $ do
+ { ctxt <- getErrCtxt
+ ; doc <- mkErrInfo emptyTidyEnv ctxt
+ ; traceTc "utype_defer" (vcat [ debugPprType ty1
+ , debugPprType ty2
+ , pprCtOrigin origin
+ , doc])
+ ; traceTc "utype_defer2" (ppr co)
+ }
+ ; return co }
+
+--------------
+uType t_or_k origin orig_ty1 orig_ty2
+ = do { tclvl <- getTcLevel
+ ; traceTc "u_tys" $ vcat
+ [ text "tclvl" <+> ppr tclvl
+ , sep [ ppr orig_ty1, text "~", ppr orig_ty2]
+ , pprCtOrigin origin]
+ ; co <- go orig_ty1 orig_ty2
+ ; if isReflCo co
+ then traceTc "u_tys yields no coercion" Outputable.empty
+ else traceTc "u_tys yields coercion:" (ppr co)
+ ; return co }
+ where
+ go :: TcType -> TcType -> TcM CoercionN
+ -- The arguments to 'go' are always semantically identical
+ -- to orig_ty{1,2} except for looking through type synonyms
+
+ -- Unwrap casts before looking for variables. This way, we can easily
+ -- recognize (t |> co) ~ (t |> co), which is nice. Previously, we
+ -- didn't do it this way, and then the unification above was deferred.
+ go (CastTy t1 co1) t2
+ = do { co_tys <- uType t_or_k origin t1 t2
+ ; return (mkCoherenceLeftCo Nominal t1 co1 co_tys) }
+
+ go t1 (CastTy t2 co2)
+ = do { co_tys <- uType t_or_k origin t1 t2
+ ; return (mkCoherenceRightCo Nominal t2 co2 co_tys) }
+
+ -- Variables; go for uUnfilledVar
+ -- Note that we pass in *original* (before synonym expansion),
+ -- so that type variables tend to get filled in with
+ -- the most informative version of the type
+ go (TyVarTy tv1) ty2
+ = do { lookup_res <- lookupTcTyVar tv1
+ ; case lookup_res of
+ Filled ty1 -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1)
+ ; go ty1 ty2 }
+ Unfilled _ -> uUnfilledVar origin t_or_k NotSwapped tv1 ty2 }
+ go ty1 (TyVarTy tv2)
+ = do { lookup_res <- lookupTcTyVar tv2
+ ; case lookup_res of
+ Filled ty2 -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2)
+ ; go ty1 ty2 }
+ Unfilled _ -> uUnfilledVar origin t_or_k IsSwapped tv2 ty1 }
+
+ -- See Note [Expanding synonyms during unification]
+ go ty1@(TyConApp tc1 []) (TyConApp tc2 [])
+ | tc1 == tc2
+ = return $ mkNomReflCo ty1
+
+ -- See Note [Expanding synonyms during unification]
+ --
+ -- Also NB that we recurse to 'go' so that we don't push a
+ -- new item on the origin stack. As a result if we have
+ -- type Foo = Int
+ -- and we try to unify Foo ~ Bool
+ -- we'll end up saying "can't match Foo with Bool"
+ -- rather than "can't match "Int with Bool". See #4535.
+ go ty1 ty2
+ | Just ty1' <- tcView ty1 = go ty1' ty2
+ | Just ty2' <- tcView ty2 = go ty1 ty2'
+
+ -- Functions (or predicate functions) just check the two parts
+ go (FunTy _ fun1 arg1) (FunTy _ fun2 arg2)
+ = do { co_l <- uType t_or_k origin fun1 fun2
+ ; co_r <- uType t_or_k origin arg1 arg2
+ ; return $ mkFunCo Nominal co_l co_r }
+
+ -- Always defer if a type synonym family (type function)
+ -- is involved. (Data families behave rigidly.)
+ go ty1@(TyConApp tc1 _) ty2
+ | isTypeFamilyTyCon tc1 = defer ty1 ty2
+ go ty1 ty2@(TyConApp tc2 _)
+ | isTypeFamilyTyCon tc2 = defer ty1 ty2
+
+ go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+ -- See Note [Mismatched type lists and application decomposition]
+ | tc1 == tc2, equalLength tys1 tys2
+ = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 )
+ do { cos <- zipWith3M (uType t_or_k) origins' tys1 tys2
+ ; return $ mkTyConAppCo Nominal tc1 cos }
+ where
+ origins' = map (\is_vis -> if is_vis then origin else toInvisibleOrigin origin)
+ (tcTyConVisibilities tc1)
+
+ go (LitTy m) ty@(LitTy n)
+ | m == n
+ = return $ mkNomReflCo ty
+
+ -- See Note [Care with type applications]
+ -- Do not decompose FunTy against App;
+ -- it's often a type error, so leave it for the constraint solver
+ go (AppTy s1 t1) (AppTy s2 t2)
+ = go_app (isNextArgVisible s1) s1 t1 s2 t2
+
+ go (AppTy s1 t1) (TyConApp tc2 ts2)
+ | Just (ts2', t2') <- snocView ts2
+ = ASSERT( not (mustBeSaturated tc2) )
+ go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2'
+
+ go (TyConApp tc1 ts1) (AppTy s2 t2)
+ | Just (ts1', t1') <- snocView ts1
+ = ASSERT( not (mustBeSaturated tc1) )
+ go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2
+
+ go (CoercionTy co1) (CoercionTy co2)
+ = do { let ty1 = coercionType co1
+ ty2 = coercionType co2
+ ; kco <- uType KindLevel
+ (KindEqOrigin orig_ty1 (Just orig_ty2) origin
+ (Just t_or_k))
+ ty1 ty2
+ ; return $ mkProofIrrelCo Nominal kco co1 co2 }
+
+ -- Anything else fails
+ -- E.g. unifying for-all types, which is relative unusual
+ go ty1 ty2 = defer ty1 ty2
+
+ ------------------
+ defer ty1 ty2 -- See Note [Check for equality before deferring]
+ | ty1 `tcEqType` ty2 = return (mkNomReflCo ty1)
+ | otherwise = uType_defer t_or_k origin ty1 ty2
+
+ ------------------
+ go_app vis s1 t1 s2 t2
+ = do { co_s <- uType t_or_k origin s1 s2
+ ; let arg_origin
+ | vis = origin
+ | otherwise = toInvisibleOrigin origin
+ ; co_t <- uType t_or_k arg_origin t1 t2
+ ; return $ mkAppCo co_s co_t }
+
+{- Note [Check for equality before deferring]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Particularly in ambiguity checks we can get equalities like (ty ~ ty).
+If ty involves a type function we may defer, which isn't very sensible.
+An egregious example of this was in test T9872a, which has a type signature
+ Proxy :: Proxy (Solutions Cubes)
+Doing the ambiguity check on this signature generates the equality
+ Solutions Cubes ~ Solutions Cubes
+and currently the constraint solver normalises both sides at vast cost.
+This little short-cut in 'defer' helps quite a bit.
+
+Note [Care with type applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note: type applications need a bit of care!
+They can match FunTy and TyConApp, so use splitAppTy_maybe
+NB: we've already dealt with type variables and Notes,
+so if one type is an App the other one jolly well better be too
+
+Note [Mismatched type lists and application decomposition]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we find two TyConApps, you might think that the argument lists
+are guaranteed equal length. But they aren't. Consider matching
+ w (T x) ~ Foo (T x y)
+We do match (w ~ Foo) first, but in some circumstances we simply create
+a deferred constraint; and then go ahead and match (T x ~ T x y).
+This came up in #3950.
+
+So either
+ (a) either we must check for identical argument kinds
+ when decomposing applications,
+
+ (b) or we must be prepared for ill-kinded unification sub-problems
+
+Currently we adopt (b) since it seems more robust -- no need to maintain
+a global invariant.
+
+Note [Expanding synonyms during unification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We expand synonyms during unification, but:
+ * We expand *after* the variable case so that we tend to unify
+ variables with un-expanded type synonym. This just makes it
+ more likely that the inferred types will mention type synonyms
+ understandable to the user
+
+ * Similarly, we expand *after* the CastTy case, just in case the
+ CastTy wraps a variable.
+
+ * We expand *before* the TyConApp case. For example, if we have
+ type Phantom a = Int
+ and are unifying
+ Phantom Int ~ Phantom Char
+ it is *wrong* to unify Int and Char.
+
+ * The problem case immediately above can happen only with arguments
+ to the tycon. So we check for nullary tycons *before* expanding.
+ This is particularly helpful when checking (* ~ *), because * is
+ now a type synonym.
+
+Note [Deferred Unification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically,
+and yet its consistency is undetermined. Previously, there was no way to still
+make it consistent. So a mismatch error was issued.
+
+Now these unifications are deferred until constraint simplification, where type
+family instances and given equations may (or may not) establish the consistency.
+Deferred unifications are of the form
+ F ... ~ ...
+or x ~ ...
+where F is a type function and x is a type variable.
+E.g.
+ id :: x ~ y => x -> y
+ id e = e
+
+involves the unification x = y. It is deferred until we bring into account the
+context x ~ y to establish that it holds.
+
+If available, we defer original types (rather than those where closed type
+synonyms have already been expanded via tcCoreView). This is, as usual, to
+improve error messages.
+
+
+************************************************************************
+* *
+ uUnfilledVar and friends
+* *
+************************************************************************
+
+@uunfilledVar@ is called when at least one of the types being unified is a
+variable. It does {\em not} assume that the variable is a fixed point
+of the substitution; rather, notice that @uVar@ (defined below) nips
+back into @uTys@ if it turns out that the variable is already bound.
+-}
+
+----------
+uUnfilledVar :: CtOrigin
+ -> TypeOrKind
+ -> SwapFlag
+ -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar
+ -- definitely not a /filled/ meta-tyvar
+ -> TcTauType -- Type 2
+ -> TcM Coercion
+-- "Unfilled" means that the variable is definitely not a filled-in meta tyvar
+-- It might be a skolem, or untouchable, or meta
+
+uUnfilledVar origin t_or_k swapped tv1 ty2
+ = do { ty2 <- zonkTcType ty2
+ -- Zonk to expose things to the
+ -- occurs check, and so that if ty2
+ -- looks like a type variable then it
+ -- /is/ a type variable
+ ; uUnfilledVar1 origin t_or_k swapped tv1 ty2 }
+
+----------
+uUnfilledVar1 :: CtOrigin
+ -> TypeOrKind
+ -> SwapFlag
+ -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar
+ -- definitely not a /filled/ meta-tyvar
+ -> TcTauType -- Type 2, zonked
+ -> TcM Coercion
+uUnfilledVar1 origin t_or_k swapped tv1 ty2
+ | Just tv2 <- tcGetTyVar_maybe ty2
+ = go tv2
+
+ | otherwise
+ = uUnfilledVar2 origin t_or_k swapped tv1 ty2
+
+ where
+ -- 'go' handles the case where both are
+ -- tyvars so we might want to swap
+ -- E.g. maybe tv2 is a meta-tyvar and tv1 is not
+ go tv2 | tv1 == tv2 -- Same type variable => no-op
+ = return (mkNomReflCo (mkTyVarTy tv1))
+
+ | swapOverTyVars tv1 tv2 -- Distinct type variables
+ -- Swap meta tyvar to the left if poss
+ = do { tv1 <- zonkTyCoVarKind tv1
+ -- We must zonk tv1's kind because that might
+ -- not have happened yet, and it's an invariant of
+ -- uUnfilledTyVar2 that ty2 is fully zonked
+ -- Omitting this caused #16902
+ ; uUnfilledVar2 origin t_or_k (flipSwap swapped)
+ tv2 (mkTyVarTy tv1) }
+
+ | otherwise
+ = uUnfilledVar2 origin t_or_k swapped tv1 ty2
+
+----------
+uUnfilledVar2 :: CtOrigin
+ -> TypeOrKind
+ -> SwapFlag
+ -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar
+ -- definitely not a /filled/ meta-tyvar
+ -> TcTauType -- Type 2, zonked
+ -> TcM Coercion
+uUnfilledVar2 origin t_or_k swapped tv1 ty2
+ = do { dflags <- getDynFlags
+ ; cur_lvl <- getTcLevel
+ ; go dflags cur_lvl }
+ where
+ go dflags cur_lvl
+ | canSolveByUnification cur_lvl tv1 ty2
+ , MTVU_OK ty2' <- metaTyVarUpdateOK dflags tv1 ty2
+ = do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2') (tyVarKind tv1)
+ ; traceTc "uUnfilledVar2 ok" $
+ vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)
+ , ppr ty2 <+> dcolon <+> ppr (tcTypeKind ty2)
+ , ppr (isTcReflCo co_k), ppr co_k ]
+
+ ; if isTcReflCo co_k
+ -- Only proceed if the kinds match
+ -- NB: tv1 should still be unfilled, despite the kind unification
+ -- because tv1 is not free in ty2 (or, hence, in its kind)
+ then do { writeMetaTyVar tv1 ty2'
+ ; return (mkTcNomReflCo ty2') }
+
+ else defer } -- This cannot be solved now. See GHC.Tc.Solver.Canonical
+ -- Note [Equalities with incompatible kinds]
+
+ | otherwise
+ = do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2)
+ -- Occurs check or an untouchable: just defer
+ -- NB: occurs check isn't necessarily fatal:
+ -- eg tv1 occurred in type family parameter
+ ; defer }
+
+ ty1 = mkTyVarTy tv1
+ kind_origin = KindEqOrigin ty1 (Just ty2) origin (Just t_or_k)
+
+ defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2
+
+swapOverTyVars :: TcTyVar -> TcTyVar -> Bool
+swapOverTyVars tv1 tv2
+ -- Level comparison: see Note [TyVar/TyVar orientation]
+ | lvl1 `strictlyDeeperThan` lvl2 = False
+ | lvl2 `strictlyDeeperThan` lvl1 = True
+
+ -- Priority: see Note [TyVar/TyVar orientation]
+ | pri1 > pri2 = False
+ | pri2 > pri1 = True
+
+ -- Names: see Note [TyVar/TyVar orientation]
+ | isSystemName tv2_name, not (isSystemName tv1_name) = True
+
+ | otherwise = False
+
+ where
+ lvl1 = tcTyVarLevel tv1
+ lvl2 = tcTyVarLevel tv2
+ pri1 = lhsPriority tv1
+ pri2 = lhsPriority tv2
+ tv1_name = Var.varName tv1
+ tv2_name = Var.varName tv2
+
+
+lhsPriority :: TcTyVar -> Int
+-- Higher => more important to be on the LHS
+-- See Note [TyVar/TyVar orientation]
+lhsPriority tv
+ = ASSERT2( isTyVar tv, ppr tv)
+ case tcTyVarDetails tv of
+ RuntimeUnk -> 0
+ SkolemTv {} -> 0
+ MetaTv { mtv_info = info } -> case info of
+ FlatSkolTv -> 1
+ TyVarTv -> 2
+ TauTv -> 3
+ FlatMetaTv -> 4
+{- Note [TyVar/TyVar orientation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given (a ~ b), should we orient the CTyEqCan as (a~b) or (b~a)?
+This is a surprisingly tricky question! This is invariant (TyEq:TV).
+
+The question is answered by swapOverTyVars, which is use
+ - in the eager unifier, in GHC.Tc.Utils.Unify.uUnfilledVar1
+ - in the constraint solver, in GHC.Tc.Solver.Canonical.canEqTyVarHomo
+
+First note: only swap if you have to!
+ See Note [Avoid unnecessary swaps]
+
+So we look for a positive reason to swap, using a three-step test:
+
+* Level comparison. If 'a' has deeper level than 'b',
+ put 'a' on the left. See Note [Deeper level on the left]
+
+* Priority. If the levels are the same, look at what kind of
+ type variable it is, using 'lhsPriority'.
+
+ Generally speaking we always try to put a MetaTv on the left
+ in preference to SkolemTv or RuntimeUnkTv:
+ a) Because the MetaTv may be touchable and can be unified
+ b) Even if it's not touchable, GHC.Tc.Solver.floatEqualities
+ looks for meta tyvars on the left
+
+ Tie-breaking rules for MetaTvs:
+ - FlatMetaTv = 4: always put on the left.
+ See Note [Fmv Orientation Invariant]
+
+ NB: FlatMetaTvs always have the current level, never an
+ outer one. So nothing can be deeper than a FlatMetaTv.
+
+ - TauTv = 3: if we have tyv_tv ~ tau_tv,
+ put tau_tv on the left because there are fewer
+ restrictions on updating TauTvs. Or to say it another
+ way, then we won't lose the TyVarTv flag
+
+ - TyVarTv = 2: remember, flat-skols are *only* updated by
+ the unflattener, never unified, so TyVarTvs come next
+
+ - FlatSkolTv = 1: put on the left in preference to a SkolemTv.
+ See Note [Eliminate flat-skols]
+
+* Names. If the level and priority comparisons are all
+ equal, try to eliminate a TyVars with a System Name in
+ favour of ones with a Name derived from a user type signature
+
+* Age. At one point in the past we tried to break any remaining
+ ties by eliminating the younger type variable, based on their
+ Uniques. See Note [Eliminate younger unification variables]
+ (which also explains why we don't do this any more)
+
+Note [Deeper level on the left]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The most important thing is that we want to put tyvars with
+the deepest level on the left. The reason to do so differs for
+Wanteds and Givens, but either way, deepest wins! Simple.
+
+* Wanteds. Putting the deepest variable on the left maximise the
+ chances that it's a touchable meta-tyvar which can be solved.
+
+* Givens. Suppose we have something like
+ forall a[2]. b[1] ~ a[2] => beta[1] ~ a[2]
+
+ If we orient the Given a[2] on the left, we'll rewrite the Wanted to
+ (beta[1] ~ b[1]), and that can float out of the implication.
+ Otherwise it can't. By putting the deepest variable on the left
+ we maximise our changes of eliminating skolem capture.
+
+ See also GHC.Tc.Solver.Monad Note [Let-bound skolems] for another reason
+ to orient with the deepest skolem on the left.
+
+ IMPORTANT NOTE: this test does a level-number comparison on
+ skolems, so it's important that skolems have (accurate) level
+ numbers.
+
+See #15009 for an further analysis of why "deepest on the left"
+is a good plan.
+
+Note [Fmv Orientation Invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ * We always orient a constraint
+ fmv ~ alpha
+ with fmv on the left, even if alpha is
+ a touchable unification variable
+
+Reason: doing it the other way round would unify alpha:=fmv, but that
+really doesn't add any info to alpha. But a later constraint alpha ~
+Int might unlock everything. Comment:9 of #12526 gives a detailed
+example.
+
+WARNING: I've gone to and fro on this one several times.
+I'm now pretty sure that unifying alpha:=fmv is a bad idea!
+So orienting with fmvs on the left is a good thing.
+
+This example comes from IndTypesPerfMerge. (Others include
+T10226, T10009.)
+ From the ambiguity check for
+ f :: (F a ~ a) => a
+ we get:
+ [G] F a ~ a
+ [WD] F alpha ~ alpha, alpha ~ a
+
+ From Givens we get
+ [G] F a ~ fsk, fsk ~ a
+
+ Now if we flatten we get
+ [WD] alpha ~ fmv, F alpha ~ fmv, alpha ~ a
+
+ Now, if we unified alpha := fmv, we'd get
+ [WD] F fmv ~ fmv, [WD] fmv ~ a
+ And now we are stuck.
+
+So instead the Fmv Orientation Invariant puts the fmv on the
+left, giving
+ [WD] fmv ~ alpha, [WD] F alpha ~ fmv, [WD] alpha ~ a
+
+ Now we get alpha:=a, and everything works out
+
+Note [Eliminate flat-skols]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have [G] Num (F [a])
+then we flatten to
+ [G] Num fsk
+ [G] F [a] ~ fsk
+where fsk is a flatten-skolem (FlatSkolTv). Suppose we have
+ type instance F [a] = a
+then we'll reduce the second constraint to
+ [G] a ~ fsk
+and then replace all uses of 'a' with fsk. That's bad because
+in error messages instead of saying 'a' we'll say (F [a]). In all
+places, including those where the programmer wrote 'a' in the first
+place. Very confusing! See #7862.
+
+Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate
+the fsk.
+
+Note [Avoid unnecessary swaps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we swap without actually improving matters, we can get an infinite loop.
+Consider
+ work item: a ~ b
+ inert item: b ~ c
+We canonicalise the work-item to (a ~ c). If we then swap it before
+adding to the inert set, we'll add (c ~ a), and therefore kick out the
+inert guy, so we get
+ new work item: b ~ c
+ inert item: c ~ a
+And now the cycle just repeats
+
+Note [Eliminate younger unification variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given a choice of unifying
+ alpha := beta or beta := alpha
+we try, if possible, to eliminate the "younger" one, as determined
+by `ltUnique`. Reason: the younger one is less likely to appear free in
+an existing inert constraint, and hence we are less likely to be forced
+into kicking out and rewriting inert constraints.
+
+This is a performance optimisation only. It turns out to fix
+#14723 all by itself, but clearly not reliably so!
+
+It's simple to implement (see nicer_to_update_tv2 in swapOverTyVars).
+But, to my surprise, it didn't seem to make any significant difference
+to the compiler's performance, so I didn't take it any further. Still
+it seemed to too nice to discard altogether, so I'm leaving these
+notes. SLPJ Jan 18.
+-}
+
+-- @trySpontaneousSolve wi@ solves equalities where one side is a
+-- touchable unification variable.
+-- Returns True <=> spontaneous solve happened
+canSolveByUnification :: TcLevel -> TcTyVar -> TcType -> Bool
+canSolveByUnification tclvl tv xi
+ | isTouchableMetaTyVar tclvl tv
+ = case metaTyVarInfo tv of
+ TyVarTv -> is_tyvar xi
+ _ -> True
+
+ | otherwise -- Untouchable
+ = False
+ where
+ is_tyvar xi
+ = case tcGetTyVar_maybe xi of
+ Nothing -> False
+ Just tv -> case tcTyVarDetails tv of
+ MetaTv { mtv_info = info }
+ -> case info of
+ TyVarTv -> True
+ _ -> False
+ SkolemTv {} -> True
+ RuntimeUnk -> True
+
+{- Note [Prevent unification with type families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We prevent unification with type families because of an uneasy compromise.
+It's perfectly sound to unify with type families, and it even improves the
+error messages in the testsuite. It also modestly improves performance, at
+least in some cases. But it's disastrous for test case perf/compiler/T3064.
+Here is the problem: Suppose we have (F ty) where we also have [G] F ty ~ a.
+What do we do? Do we reduce F? Or do we use the given? Hard to know what's
+best. GHC reduces. This is a disaster for T3064, where the type's size
+spirals out of control during reduction. (We're not helped by the fact that
+the flattener re-flattens all the arguments every time around.) If we prevent
+unification with type families, then the solver happens to use the equality
+before expanding the type family.
+
+It would be lovely in the future to revisit this problem and remove this
+extra, unnecessary check. But we retain it for now as it seems to work
+better in practice.
+
+Note [Refactoring hazard: checkTauTvUpdate]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+I (Richard E.) have a sad story about refactoring this code, retained here
+to prevent others (or a future me!) from falling into the same traps.
+
+It all started with #11407, which was caused by the fact that the TyVarTy
+case of defer_me didn't look in the kind. But it seemed reasonable to
+simply remove the defer_me check instead.
+
+It referred to two Notes (since removed) that were out of date, and the
+fast_check code in occurCheckExpand seemed to do just about the same thing as
+defer_me. The one piece that defer_me did that wasn't repeated by
+occurCheckExpand was the type-family check. (See Note [Prevent unification
+with type families].) So I checked the result of occurCheckExpand for any
+type family occurrences and deferred if there were any. This was done
+in commit e9bf7bb5cc9fb3f87dd05111aa23da76b86a8967 .
+
+This approach turned out not to be performant, because the expanded
+type was bigger than the original type, and tyConsOfType (needed to
+see if there are any type family occurrences) looks through type
+synonyms. So it then struck me that we could dispense with the
+defer_me check entirely. This simplified the code nicely, and it cut
+the allocations in T5030 by half. But, as documented in Note [Prevent
+unification with type families], this destroyed performance in
+T3064. Regardless, I missed this regression and the change was
+committed as 3f5d1a13f112f34d992f6b74656d64d95a3f506d .
+
+Bottom lines:
+ * defer_me is back, but now fixed w.r.t. #11407.
+ * Tread carefully before you start to refactor here. There can be
+ lots of hard-to-predict consequences.
+
+Note [Type synonyms and the occur check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generally speaking we try to update a variable with type synonyms not
+expanded, which improves later error messages, unless looking
+inside a type synonym may help resolve a spurious occurs check
+error. Consider:
+ type A a = ()
+
+ f :: (A a -> a -> ()) -> ()
+ f = \ _ -> ()
+
+ x :: ()
+ x = f (\ x p -> p x)
+
+We will eventually get a constraint of the form t ~ A t. The ok function above will
+properly expand the type (A t) to just (), which is ok to be unified with t. If we had
+unified with the original type A t, we would lead the type checker into an infinite loop.
+
+Hence, if the occurs check fails for a type synonym application, then (and *only* then),
+the ok function expands the synonym to detect opportunities for occurs check success using
+the underlying definition of the type synonym.
+
+The same applies later on in the constraint interaction code; see GHC.Tc.Solver.Interact,
+function @occ_check_ok@.
+
+Note [Non-TcTyVars in GHC.Tc.Utils.Unify]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because the same code is now shared between unifying types and unifying
+kinds, we sometimes will see proper TyVars floating around the unifier.
+Example (from test case polykinds/PolyKinds12):
+
+ type family Apply (f :: k1 -> k2) (x :: k1) :: k2
+ type instance Apply g y = g y
+
+When checking the instance declaration, we first *kind-check* the LHS
+and RHS, discovering that the instance really should be
+
+ type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y
+
+During this kind-checking, all the tyvars will be TcTyVars. Then, however,
+as a second pass, we desugar the RHS (which is done in functions prefixed
+with "tc" in GHC.Tc.TyCl"). By this time, all the kind-vars are proper
+TyVars, not TcTyVars, get some kind unification must happen.
+
+Thus, we always check if a TyVar is a TcTyVar before asking if it's a
+meta-tyvar.
+
+This used to not be necessary for type-checking (that is, before * :: *)
+because expressions get desugared via an algorithm separate from
+type-checking (with wrappers, etc.). Types get desugared very differently,
+causing this wibble in behavior seen here.
+-}
+
+data LookupTyVarResult -- The result of a lookupTcTyVar call
+ = Unfilled TcTyVarDetails -- SkolemTv or virgin MetaTv
+ | Filled TcType
+
+lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult
+lookupTcTyVar tyvar
+ | MetaTv { mtv_ref = ref } <- details
+ = do { meta_details <- readMutVar ref
+ ; case meta_details of
+ Indirect ty -> return (Filled ty)
+ Flexi -> do { is_touchable <- isTouchableTcM tyvar
+ -- Note [Unifying untouchables]
+ ; if is_touchable then
+ return (Unfilled details)
+ else
+ return (Unfilled vanillaSkolemTv) } }
+ | otherwise
+ = return (Unfilled details)
+ where
+ details = tcTyVarDetails tyvar
+
+{-
+Note [Unifying untouchables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We treat an untouchable type variable as if it was a skolem. That
+ensures it won't unify with anything. It's a slight hack, because
+we return a made-up TcTyVarDetails, but I think it works smoothly.
+-}
+
+-- | Breaks apart a function kind into its pieces.
+matchExpectedFunKind
+ :: Outputable fun
+ => fun -- ^ type, only for errors
+ -> Arity -- ^ n: number of desired arrows
+ -> TcKind -- ^ fun_ kind
+ -> TcM Coercion -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res)
+
+matchExpectedFunKind hs_ty n k = go n k
+ where
+ go 0 k = return (mkNomReflCo k)
+
+ go n k | Just k' <- tcView k = go n k'
+
+ go n k@(TyVarTy kvar)
+ | isMetaTyVar kvar
+ = do { maybe_kind <- readMetaTyVar kvar
+ ; case maybe_kind of
+ Indirect fun_kind -> go n fun_kind
+ Flexi -> defer n k }
+
+ go n (FunTy _ arg res)
+ = do { co <- go (n-1) res
+ ; return (mkTcFunCo Nominal (mkTcNomReflCo arg) co) }
+
+ go n other
+ = defer n other
+
+ defer n k
+ = do { arg_kinds <- newMetaKindVars n
+ ; res_kind <- newMetaKindVar
+ ; let new_fun = mkVisFunTys arg_kinds res_kind
+ origin = TypeEqOrigin { uo_actual = k
+ , uo_expected = new_fun
+ , uo_thing = Just (ppr hs_ty)
+ , uo_visible = True
+ }
+ ; uType KindLevel origin k new_fun }
+
+{- *********************************************************************
+* *
+ Occurrence checking
+* *
+********************************************************************* -}
+
+
+{- Note [Occurrence checking: look inside kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are considering unifying
+ (alpha :: *) ~ Int -> (beta :: alpha -> alpha)
+This may be an error (what is that alpha doing inside beta's kind?),
+but we must not make the mistake of actually unifying or we'll
+build an infinite data structure. So when looking for occurrences
+of alpha in the rhs, we must look in the kinds of type variables
+that occur there.
+
+NB: we may be able to remove the problem via expansion; see
+ Note [Occurs check expansion]. So we have to try that.
+
+Note [Checking for foralls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Unless we have -XImpredicativeTypes (which is a totally unsupported
+feature), we do not want to unify
+ alpha ~ (forall a. a->a) -> Int
+So we look for foralls hidden inside the type, and it's convenient
+to do that at the same time as the occurs check (which looks for
+occurrences of alpha).
+
+However, it's not just a question of looking for foralls /anywhere/!
+Consider
+ (alpha :: forall k. k->*) ~ (beta :: forall k. k->*)
+This is legal; e.g. dependent/should_compile/T11635.
+
+We don't want to reject it because of the forall in beta's kind,
+but (see Note [Occurrence checking: look inside kinds]) we do
+need to look in beta's kind. So we carry a flag saying if a 'forall'
+is OK, and switch the flag on when stepping inside a kind.
+
+Why is it OK? Why does it not count as impredicative polymorphism?
+The reason foralls are bad is because we reply on "seeing" foralls
+when doing implicit instantiation. But the forall inside the kind is
+fine. We'll generate a kind equality constraint
+ (forall k. k->*) ~ (forall k. k->*)
+to check that the kinds of lhs and rhs are compatible. If alpha's
+kind had instead been
+ (alpha :: kappa)
+then this kind equality would rightly complain about unifying kappa
+with (forall k. k->*)
+
+-}
+
+data MetaTyVarUpdateResult a
+ = MTVU_OK a
+ | MTVU_Bad -- Forall, predicate, or type family
+ | MTVU_HoleBlocker -- Blocking coercion hole
+ -- See Note [Equalities with incompatible kinds] in TcCanonical
+ | MTVU_Occurs
+ deriving (Functor)
+
+instance Applicative MetaTyVarUpdateResult where
+ pure = MTVU_OK
+ (<*>) = ap
+
+instance Monad MetaTyVarUpdateResult where
+ MTVU_OK x >>= k = k x
+ MTVU_Bad >>= _ = MTVU_Bad
+ MTVU_HoleBlocker >>= _ = MTVU_HoleBlocker
+ MTVU_Occurs >>= _ = MTVU_Occurs
+
+instance Outputable a => Outputable (MetaTyVarUpdateResult a) where
+ ppr (MTVU_OK a) = text "MTVU_OK" <+> ppr a
+ ppr MTVU_Bad = text "MTVU_Bad"
+ ppr MTVU_HoleBlocker = text "MTVU_HoleBlocker"
+ ppr MTVU_Occurs = text "MTVU_Occurs"
+
+occCheckForErrors :: DynFlags -> TcTyVar -> Type -> MetaTyVarUpdateResult ()
+-- Just for error-message generation; so we return MetaTyVarUpdateResult
+-- so the caller can report the right kind of error
+-- Check whether
+-- a) the given variable occurs in the given type.
+-- b) there is a forall in the type (unless we have -XImpredicativeTypes)
+occCheckForErrors dflags tv ty
+ = case preCheck dflags True tv ty of
+ MTVU_OK _ -> MTVU_OK ()
+ MTVU_Bad -> MTVU_Bad
+ MTVU_HoleBlocker -> MTVU_HoleBlocker
+ MTVU_Occurs -> case occCheckExpand [tv] ty of
+ Nothing -> MTVU_Occurs
+ Just _ -> MTVU_OK ()
+
+----------------
+metaTyVarUpdateOK :: DynFlags
+ -> TcTyVar -- tv :: k1
+ -> TcType -- ty :: k2
+ -> MetaTyVarUpdateResult TcType -- possibly-expanded ty
+-- (metaTyVarUpdateOK tv ty)
+-- We are about to update the meta-tyvar tv with ty
+-- Check (a) that tv doesn't occur in ty (occurs check)
+-- (b) that ty does not have any foralls
+-- (in the impredicative case), or type functions
+-- (c) that ty does not have any blocking coercion holes
+-- See Note [Equalities with incompatible kinds] in TcCanonical
+--
+-- We have two possible outcomes:
+-- (1) Return the type to update the type variable with,
+-- [we know the update is ok]
+-- (2) Return Nothing,
+-- [the update might be dodgy]
+--
+-- Note that "Nothing" does not mean "definite error". For example
+-- type family F a
+-- type instance F Int = Int
+-- consider
+-- a ~ F a
+-- This is perfectly reasonable, if we later get a ~ Int. For now, though,
+-- we return Nothing, leaving it to the later constraint simplifier to
+-- sort matters out.
+--
+-- See Note [Refactoring hazard: checkTauTvUpdate]
+
+metaTyVarUpdateOK dflags tv ty
+ = case preCheck dflags False tv ty of
+ -- False <=> type families not ok
+ -- See Note [Prevent unification with type families]
+ MTVU_OK _ -> MTVU_OK ty
+ MTVU_Bad -> MTVU_Bad -- forall, predicate, type function
+ MTVU_HoleBlocker -> MTVU_HoleBlocker -- coercion hole
+ MTVU_Occurs -> case occCheckExpand [tv] ty of
+ Just expanded_ty -> MTVU_OK expanded_ty
+ Nothing -> MTVU_Occurs
+
+preCheck :: DynFlags -> Bool -> TcTyVar -> TcType -> MetaTyVarUpdateResult ()
+-- A quick check for
+-- (a) a forall type (unless -XImpredicativeTypes)
+-- (b) a predicate type (unless -XImpredicativeTypes)
+-- (c) a type family
+-- (d) a blocking coercion hole
+-- (e) an occurrence of the type variable (occurs check)
+--
+-- For (a), (b), and (c) we check only the top level of the type, NOT
+-- inside the kinds of variables it mentions. For (d) we look deeply
+-- in coercions, and for (e) we do look in the kinds of course.
+
+preCheck dflags ty_fam_ok tv ty
+ = fast_check ty
+ where
+ details = tcTyVarDetails tv
+ impredicative_ok = canUnifyWithPolyType dflags details
+
+ ok :: MetaTyVarUpdateResult ()
+ ok = MTVU_OK ()
+
+ fast_check :: TcType -> MetaTyVarUpdateResult ()
+ fast_check (TyVarTy tv')
+ | tv == tv' = MTVU_Occurs
+ | otherwise = fast_check_occ (tyVarKind tv')
+ -- See Note [Occurrence checking: look inside kinds]
+
+ fast_check (TyConApp tc tys)
+ | bad_tc tc = MTVU_Bad
+ | otherwise = mapM fast_check tys >> ok
+ fast_check (LitTy {}) = ok
+ fast_check (FunTy{ft_af = af, ft_arg = a, ft_res = r})
+ | InvisArg <- af
+ , not impredicative_ok = MTVU_Bad
+ | otherwise = fast_check a >> fast_check r
+ fast_check (AppTy fun arg) = fast_check fun >> fast_check arg
+ fast_check (CastTy ty co) = fast_check ty >> fast_check_co co
+ fast_check (CoercionTy co) = fast_check_co co
+ fast_check (ForAllTy (Bndr tv' _) ty)
+ | not impredicative_ok = MTVU_Bad
+ | tv == tv' = ok
+ | otherwise = do { fast_check_occ (tyVarKind tv')
+ ; fast_check_occ ty }
+ -- Under a forall we look only for occurrences of
+ -- the type variable
+
+ -- For kinds, we only do an occurs check; we do not worry
+ -- about type families or foralls
+ -- See Note [Checking for foralls]
+ fast_check_occ k | tv `elemVarSet` tyCoVarsOfType k = MTVU_Occurs
+ | otherwise = ok
+
+ -- no bother about impredicativity in coercions, as they're
+ -- inferred
+ fast_check_co co | not (gopt Opt_DeferTypeErrors dflags)
+ , badCoercionHoleCo co = MTVU_HoleBlocker
+ -- Wrinkle (4b) in TcCanonical Note [Equalities with incompatible kinds]
+
+ | tv `elemVarSet` tyCoVarsOfCo co = MTVU_Occurs
+ | otherwise = ok
+
+ bad_tc :: TyCon -> Bool
+ bad_tc tc
+ | not (impredicative_ok || isTauTyCon tc) = True
+ | not (ty_fam_ok || isFamFreeTyCon tc) = True
+ | otherwise = False
+
+canUnifyWithPolyType :: DynFlags -> TcTyVarDetails -> Bool
+canUnifyWithPolyType dflags details
+ = case details of
+ MetaTv { mtv_info = TyVarTv } -> False
+ MetaTv { mtv_info = TauTv } -> xopt LangExt.ImpredicativeTypes dflags
+ _other -> True
+ -- We can have non-meta tyvars in given constraints
diff --git a/compiler/GHC/Tc/Utils/Unify.hs-boot b/compiler/GHC/Tc/Utils/Unify.hs-boot
new file mode 100644
index 0000000000..a281bf136b
--- /dev/null
+++ b/compiler/GHC/Tc/Utils/Unify.hs-boot
@@ -0,0 +1,15 @@
+module GHC.Tc.Utils.Unify where
+
+import GhcPrelude
+import GHC.Tc.Utils.TcType ( TcTauType )
+import GHC.Tc.Types ( TcM )
+import GHC.Tc.Types.Evidence ( TcCoercion )
+import GHC.Hs.Expr ( HsExpr )
+import GHC.Hs.Types ( HsType )
+import GHC.Hs.Extension ( GhcRn )
+
+-- This boot file exists only to tie the knot between
+-- GHC.Tc.Utils.Unify and Inst
+
+unifyType :: Maybe (HsExpr GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion
+unifyKind :: Maybe (HsType GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
new file mode 100644
index 0000000000..057535d65d
--- /dev/null
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -0,0 +1,1919 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1996-1998
+
+-}
+
+{-# LANGUAGE CPP, TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+
+-- | Specialisations of the @HsSyn@ syntax for the typechecker
+--
+-- This module is an extension of @HsSyn@ syntax, for use in the type checker.
+module GHC.Tc.Utils.Zonk (
+ -- * Extracting types from HsSyn
+ hsLitType, hsPatType, hsLPatType,
+
+ -- * Other HsSyn functions
+ mkHsDictLet, mkHsApp,
+ mkHsAppTy, mkHsCaseAlt,
+ shortCutLit, hsOverLitName,
+ conLikeResTy,
+
+ -- * re-exported from TcMonad
+ TcId, TcIdSet,
+
+ -- * Zonking
+ -- | For a description of "zonking", see Note [What is zonking?]
+ -- in GHC.Tc.Utils.TcMType
+ zonkTopDecls, zonkTopExpr, zonkTopLExpr,
+ zonkTopBndrs,
+ ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv,
+ zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX,
+ zonkTyBndrs, zonkTyBndrsX,
+ zonkTcTypeToType, zonkTcTypeToTypeX,
+ zonkTcTypesToTypes, zonkTcTypesToTypesX,
+ zonkTyVarOcc,
+ zonkCoToCo,
+ zonkEvBinds, zonkTcEvBinds,
+ zonkTcMethInfoToMethInfoX,
+ lookupTyVarOcc
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHC.Hs
+import GHC.Types.Id
+import GHC.Types.Id.Info
+import GHC.Core.Predicate
+import GHC.Tc.Utils.Monad
+import PrelNames
+import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo )
+import GHC.Tc.Utils.TcType
+import GHC.Tc.Utils.TcMType
+import GHC.Tc.Utils.Env ( tcLookupGlobalOnly )
+import GHC.Tc.Types.Evidence
+import GHC.Core.TyCo.Ppr ( pprTyVar )
+import TysPrim
+import GHC.Core.TyCon
+import TysWiredIn
+import GHC.Core.Type
+import GHC.Core.Coercion
+import GHC.Core.ConLike
+import GHC.Core.DataCon
+import GHC.Driver.Types
+import GHC.Types.Name
+import GHC.Types.Name.Env
+import GHC.Types.Var
+import GHC.Types.Var.Env
+import GHC.Platform
+import GHC.Types.Basic
+import Maybes
+import GHC.Types.SrcLoc
+import Bag
+import Outputable
+import Util
+import GHC.Types.Unique.FM
+import GHC.Core
+
+import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice)
+
+import Control.Monad
+import Data.List ( partition )
+import Control.Arrow ( second )
+
+{-
+************************************************************************
+* *
+ Extracting the type from HsSyn
+* *
+************************************************************************
+
+-}
+
+hsLPatType :: LPat GhcTc -> Type
+hsLPatType (L _ p) = hsPatType p
+
+hsPatType :: Pat GhcTc -> Type
+hsPatType (ParPat _ pat) = hsLPatType pat
+hsPatType (WildPat ty) = ty
+hsPatType (VarPat _ lvar) = idType (unLoc lvar)
+hsPatType (BangPat _ pat) = hsLPatType pat
+hsPatType (LazyPat _ pat) = hsLPatType pat
+hsPatType (LitPat _ lit) = hsLitType lit
+hsPatType (AsPat _ var _) = idType (unLoc var)
+hsPatType (ViewPat ty _ _) = ty
+hsPatType (ListPat (ListPatTc ty Nothing) _) = mkListTy ty
+hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty
+hsPatType (TuplePat tys _ bx) = mkTupleTy1 bx tys
+ -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
+hsPatType (SumPat tys _ _ _ ) = mkSumTy tys
+hsPatType (ConPatOut { pat_con = lcon
+ , pat_arg_tys = tys })
+ = conLikeResTy (unLoc lcon) tys
+hsPatType (SigPat ty _ _) = ty
+hsPatType (NPat ty _ _ _) = ty
+hsPatType (NPlusKPat ty _ _ _ _ _) = ty
+hsPatType (CoPat _ _ _ ty) = ty
+hsPatType (XPat n) = noExtCon n
+hsPatType ConPatIn{} = panic "hsPatType: ConPatIn"
+hsPatType SplicePat{} = panic "hsPatType: SplicePat"
+
+hsLitType :: HsLit (GhcPass p) -> TcType
+hsLitType (HsChar _ _) = charTy
+hsLitType (HsCharPrim _ _) = charPrimTy
+hsLitType (HsString _ _) = stringTy
+hsLitType (HsStringPrim _ _) = addrPrimTy
+hsLitType (HsInt _ _) = intTy
+hsLitType (HsIntPrim _ _) = intPrimTy
+hsLitType (HsWordPrim _ _) = wordPrimTy
+hsLitType (HsInt64Prim _ _) = int64PrimTy
+hsLitType (HsWord64Prim _ _) = word64PrimTy
+hsLitType (HsInteger _ _ ty) = ty
+hsLitType (HsRat _ _ ty) = ty
+hsLitType (HsFloatPrim _ _) = floatPrimTy
+hsLitType (HsDoublePrim _ _) = doublePrimTy
+hsLitType (XLit nec) = noExtCon nec
+
+-- Overloaded literals. Here mainly because it uses isIntTy etc
+
+shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId)
+shortCutLit platform (HsIntegral int@(IL src neg i)) ty
+ | isIntTy ty && platformInIntRange platform i = Just (HsLit noExtField (HsInt noExtField int))
+ | isWordTy ty && platformInWordRange platform i = Just (mkLit wordDataCon (HsWordPrim src i))
+ | isIntegerTy ty = Just (HsLit noExtField (HsInteger src i ty))
+ | otherwise = shortCutLit platform (HsFractional (integralFractionalLit neg i)) ty
+ -- The 'otherwise' case is important
+ -- Consider (3 :: Float). Syntactically it looks like an IntLit,
+ -- so we'll call shortCutIntLit, but of course it's a float
+ -- This can make a big difference for programs with a lot of
+ -- literals, compiled without -O
+
+shortCutLit _ (HsFractional f) ty
+ | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim noExtField f))
+ | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f))
+ | otherwise = Nothing
+
+shortCutLit _ (HsIsString src s) ty
+ | isStringTy ty = Just (HsLit noExtField (HsString src s))
+ | otherwise = Nothing
+
+mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc
+mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit)
+
+------------------------------
+hsOverLitName :: OverLitVal -> Name
+-- Get the canonical 'fromX' name for a particular OverLitVal
+hsOverLitName (HsIntegral {}) = fromIntegerName
+hsOverLitName (HsFractional {}) = fromRationalName
+hsOverLitName (HsIsString {}) = fromStringName
+
+{-
+************************************************************************
+* *
+\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
+* *
+************************************************************************
+
+The rest of the zonking is done *after* typechecking.
+The main zonking pass runs over the bindings
+
+ a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
+ b) convert unbound TcTyVar to Void
+ c) convert each TcId to an Id by zonking its type
+
+The type variables are converted by binding mutable tyvars to immutable ones
+and then zonking as normal.
+
+The Ids are converted by binding them in the normal Tc envt; that
+way we maintain sharing; eg an Id is zonked at its binding site and they
+all occurrences of that Id point to the common zonked copy
+
+It's all pretty boring stuff, because HsSyn is such a large type, and
+the environment manipulation is tiresome.
+-}
+
+-- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType.
+
+-- | See Note [The ZonkEnv]
+-- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType.
+data ZonkEnv -- See Note [The ZonkEnv]
+ = ZonkEnv { ze_flexi :: ZonkFlexi
+ , ze_tv_env :: TyCoVarEnv TyCoVar
+ , ze_id_env :: IdEnv Id
+ , ze_meta_tv_env :: TcRef (TyVarEnv Type) }
+
+{- Note [The ZonkEnv]
+~~~~~~~~~~~~~~~~~~~~~
+* ze_flexi :: ZonkFlexi says what to do with a
+ unification variable that is still un-unified.
+ See Note [Un-unified unification variables]
+
+* ze_tv_env :: TyCoVarEnv TyCoVar promotes sharing. At a binding site
+ of a tyvar or covar, we zonk the kind right away and add a mapping
+ to the env. This prevents re-zonking the kind at every
+ occurrence. But this is *just* an optimisation.
+
+* ze_id_env : IdEnv Id promotes sharing among Ids, by making all
+ occurrences of the Id point to a single zonked copy, built at the
+ binding site.
+
+ Unlike ze_tv_env, it is knot-tied: see extendIdZonkEnvRec.
+ In a mutually recursive group
+ rec { f = ...g...; g = ...f... }
+ we want the occurrence of g to point to the one zonked Id for g,
+ and the same for f.
+
+ Because it is knot-tied, we must be careful to consult it lazily.
+ Specifically, zonkIdOcc is not monadic.
+
+* ze_meta_tv_env: see Note [Sharing when zonking to Type]
+
+
+Notes:
+ * We must be careful never to put coercion variables (which are Ids,
+ after all) in the knot-tied ze_id_env, because coercions can
+ appear in types, and we sometimes inspect a zonked type in this
+ module. [Question: where, precisely?]
+
+ * In zonkTyVarOcc we consult ze_tv_env in a monadic context,
+ a second reason that ze_tv_env can't be monadic.
+
+ * An obvious suggestion would be to have one VarEnv Var to
+ replace both ze_id_env and ze_tv_env, but that doesn't work
+ because of the knot-tying stuff mentioned above.
+
+Note [Un-unified unification variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What should we do if we find a Flexi unification variable?
+There are three possibilities:
+
+* DefaultFlexi: this is the common case, in situations like
+ length @alpha ([] @alpha)
+ It really doesn't matter what type we choose for alpha. But
+ we must choose a type! We can't leave mutable unification
+ variables floating around: after typecheck is complete, every
+ type variable occurrence must have a binding site.
+
+ So we default it to 'Any' of the right kind.
+
+ All this works for both type and kind variables (indeed
+ the two are the same thing).
+
+* SkolemiseFlexi: is a special case for the LHS of RULES.
+ See Note [Zonking the LHS of a RULE]
+
+* RuntimeUnkFlexi: is a special case for the GHCi debugger.
+ It's a way to have a variable that is not a mutable
+ unification variable, but doesn't have a binding site
+ either.
+-}
+
+data ZonkFlexi -- See Note [Un-unified unification variables]
+ = DefaultFlexi -- Default unbound unification variables to Any
+ | SkolemiseFlexi -- Skolemise unbound unification variables
+ -- See Note [Zonking the LHS of a RULE]
+ | RuntimeUnkFlexi -- Used in the GHCi debugger
+
+instance Outputable ZonkEnv where
+ ppr (ZonkEnv { ze_tv_env = tv_env
+ , ze_id_env = id_env })
+ = text "ZE" <+> braces (vcat
+ [ text "ze_tv_env =" <+> ppr tv_env
+ , text "ze_id_env =" <+> ppr id_env ])
+
+-- The EvBinds have to already be zonked, but that's usually the case.
+emptyZonkEnv :: TcM ZonkEnv
+emptyZonkEnv = mkEmptyZonkEnv DefaultFlexi
+
+mkEmptyZonkEnv :: ZonkFlexi -> TcM ZonkEnv
+mkEmptyZonkEnv flexi
+ = do { mtv_env_ref <- newTcRef emptyVarEnv
+ ; return (ZonkEnv { ze_flexi = flexi
+ , ze_tv_env = emptyVarEnv
+ , ze_id_env = emptyVarEnv
+ , ze_meta_tv_env = mtv_env_ref }) }
+
+initZonkEnv :: (ZonkEnv -> TcM b) -> TcM b
+initZonkEnv thing_inside = do { ze <- mkEmptyZonkEnv DefaultFlexi
+ ; thing_inside ze }
+
+-- | Extend the knot-tied environment.
+extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv
+extendIdZonkEnvRec ze@(ZonkEnv { ze_id_env = id_env }) ids
+ -- NB: Don't look at the var to decide which env't to put it in. That
+ -- would end up knot-tying all the env'ts.
+ = ze { ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] }
+ -- Given coercion variables will actually end up here. That's OK though:
+ -- coercion variables are never looked up in the knot-tied env't, so zonking
+ -- them simply doesn't get optimised. No one gets hurt. An improvement (?)
+ -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the
+ -- recursive groups. But perhaps the time it takes to do the analysis is
+ -- more than the savings.
+
+extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
+extendZonkEnv ze@(ZonkEnv { ze_tv_env = tyco_env, ze_id_env = id_env }) vars
+ = ze { ze_tv_env = extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars]
+ , ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] }
+ where
+ (tycovars, ids) = partition isTyCoVar vars
+
+extendIdZonkEnv :: ZonkEnv -> Var -> ZonkEnv
+extendIdZonkEnv ze@(ZonkEnv { ze_id_env = id_env }) id
+ = ze { ze_id_env = extendVarEnv id_env id id }
+
+extendTyZonkEnv :: ZonkEnv -> TyVar -> ZonkEnv
+extendTyZonkEnv ze@(ZonkEnv { ze_tv_env = ty_env }) tv
+ = ze { ze_tv_env = extendVarEnv ty_env tv tv }
+
+setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv
+setZonkType ze flexi = ze { ze_flexi = flexi }
+
+zonkEnvIds :: ZonkEnv -> TypeEnv
+zonkEnvIds (ZonkEnv { ze_id_env = id_env})
+ = mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env]
+ -- It's OK to use nonDetEltsUFM here because we forget the ordering
+ -- immediately by creating a TypeEnv
+
+zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id
+zonkLIdOcc env = mapLoc (zonkIdOcc env)
+
+zonkIdOcc :: ZonkEnv -> TcId -> Id
+-- Ids defined in this module should be in the envt;
+-- ignore others. (Actually, data constructors are also
+-- not LocalVars, even when locally defined, but that is fine.)
+-- (Also foreign-imported things aren't currently in the ZonkEnv;
+-- that's ok because they don't need zonking.)
+--
+-- Actually, Template Haskell works in 'chunks' of declarations, and
+-- an earlier chunk won't be in the 'env' that the zonking phase
+-- carries around. Instead it'll be in the tcg_gbl_env, already fully
+-- zonked. There's no point in looking it up there (except for error
+-- checking), and it's not conveniently to hand; hence the simple
+-- 'orElse' case in the LocalVar branch.
+--
+-- Even without template splices, in module Main, the checking of
+-- 'main' is done as a separate chunk.
+zonkIdOcc (ZonkEnv { ze_id_env = id_env}) id
+ | isLocalVar id = lookupVarEnv id_env id `orElse`
+ id
+ | otherwise = id
+
+zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
+zonkIdOccs env ids = map (zonkIdOcc env) ids
+
+-- zonkIdBndr is used *after* typechecking to get the Id's type
+-- to its final form. The TyVarEnv give
+zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
+zonkIdBndr env v
+ = do ty' <- zonkTcTypeToTypeX env (idType v)
+ ensureNotLevPoly ty'
+ (text "In the type of binder" <+> quotes (ppr v))
+
+ return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty'))
+
+zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
+zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
+
+zonkTopBndrs :: [TcId] -> TcM [Id]
+zonkTopBndrs ids = initZonkEnv $ \ ze -> zonkIdBndrs ze ids
+
+zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc)
+zonkFieldOcc env (FieldOcc sel lbl)
+ = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel
+zonkFieldOcc _ (XFieldOcc nec) = noExtCon nec
+
+zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
+zonkEvBndrsX = mapAccumLM zonkEvBndrX
+
+zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
+-- Works for dictionaries and coercions
+zonkEvBndrX env var
+ = do { var' <- zonkEvBndr env var
+ ; return (extendZonkEnv env [var'], var') }
+
+zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
+-- Works for dictionaries and coercions
+-- Does not extend the ZonkEnv
+zonkEvBndr env var
+ = do { let var_ty = varType var
+ ; ty <-
+ {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
+ zonkTcTypeToTypeX env var_ty
+ ; return (setVarType var ty) }
+
+{-
+zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm
+zonkEvVarOcc env v
+ | isCoVar v
+ = EvCoercion <$> zonkCoVarOcc env v
+ | otherwise
+ = return (EvId $ zonkIdOcc env v)
+-}
+
+zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var)
+zonkCoreBndrX env v
+ | isId v = do { v' <- zonkIdBndr env v
+ ; return (extendIdZonkEnv env v', v') }
+ | otherwise = zonkTyBndrX env v
+
+zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var])
+zonkCoreBndrsX = mapAccumLM zonkCoreBndrX
+
+zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TyVar])
+zonkTyBndrs tvs = initZonkEnv $ \ze -> zonkTyBndrsX ze tvs
+
+zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])
+zonkTyBndrsX = mapAccumLM zonkTyBndrX
+
+zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)
+-- This guarantees to return a TyVar (not a TcTyVar)
+-- then we add it to the envt, so all occurrences are replaced
+--
+-- It does not clone: the new TyVar has the sane Name
+-- as the old one. This important when zonking the
+-- TyVarBndrs of a TyCon, whose Names may scope.
+zonkTyBndrX env tv
+ = ASSERT2( isImmutableTyVar tv, ppr tv <+> dcolon <+> ppr (tyVarKind tv) )
+ do { ki <- zonkTcTypeToTypeX env (tyVarKind tv)
+ -- Internal names tidy up better, for iface files.
+ ; let tv' = mkTyVar (tyVarName tv) ki
+ ; return (extendTyZonkEnv env tv', tv') }
+
+zonkTyVarBinders :: [VarBndr TcTyVar vis]
+ -> TcM (ZonkEnv, [VarBndr TyVar vis])
+zonkTyVarBinders tvbs = initZonkEnv $ \ ze -> zonkTyVarBindersX ze tvbs
+
+zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis]
+ -> TcM (ZonkEnv, [VarBndr TyVar vis])
+zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX
+
+zonkTyVarBinderX :: ZonkEnv -> VarBndr TcTyVar vis
+ -> TcM (ZonkEnv, VarBndr TyVar vis)
+-- Takes a TcTyVar and guarantees to return a TyVar
+zonkTyVarBinderX env (Bndr tv vis)
+ = do { (env', tv') <- zonkTyBndrX env tv
+ ; return (env', Bndr tv' vis) }
+
+zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc)
+zonkTopExpr e = initZonkEnv $ \ ze -> zonkExpr ze e
+
+zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)
+zonkTopLExpr e = initZonkEnv $ \ ze -> zonkLExpr ze e
+
+zonkTopDecls :: Bag EvBind
+ -> LHsBinds GhcTcId
+ -> [LRuleDecl GhcTcId] -> [LTcSpecPrag]
+ -> [LForeignDecl GhcTcId]
+ -> TcM (TypeEnv,
+ Bag EvBind,
+ LHsBinds GhcTc,
+ [LForeignDecl GhcTc],
+ [LTcSpecPrag],
+ [LRuleDecl GhcTc])
+zonkTopDecls ev_binds binds rules imp_specs fords
+ = do { (env1, ev_binds') <- initZonkEnv $ \ ze -> zonkEvBinds ze ev_binds
+ ; (env2, binds') <- zonkRecMonoBinds env1 binds
+ -- Top level is implicitly recursive
+ ; rules' <- zonkRules env2 rules
+ ; specs' <- zonkLTcSpecPrags env2 imp_specs
+ ; fords' <- zonkForeignExports env2 fords
+ ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') }
+
+---------------------------------------------
+zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId
+ -> TcM (ZonkEnv, HsLocalBinds GhcTc)
+zonkLocalBinds env (EmptyLocalBinds x)
+ = return (env, (EmptyLocalBinds x))
+
+zonkLocalBinds _ (HsValBinds _ (ValBinds {}))
+ = panic "zonkLocalBinds" -- Not in typechecker output
+
+zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs)))
+ = do { (env1, new_binds) <- go env binds
+ ; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) }
+ where
+ go env []
+ = return (env, [])
+ go env ((r,b):bs)
+ = do { (env1, b') <- zonkRecMonoBinds env b
+ ; (env2, bs') <- go env1 bs
+ ; return (env2, (r,b'):bs') }
+
+zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do
+ new_binds <- mapM (wrapLocM zonk_ip_bind) binds
+ let
+ env1 = extendIdZonkEnvRec env
+ [ n | (L _ (IPBind _ (Right n) _)) <- new_binds]
+ (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
+ return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds))
+ where
+ zonk_ip_bind (IPBind x n e)
+ = do n' <- mapIPNameTc (zonkIdBndr env) n
+ e' <- zonkLExpr env e
+ return (IPBind x n' e')
+ zonk_ip_bind (XIPBind nec) = noExtCon nec
+
+zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds nec))
+ = noExtCon nec
+zonkLocalBinds _ (XHsLocalBindsLR nec)
+ = noExtCon nec
+
+---------------------------------------------
+zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc)
+zonkRecMonoBinds env binds
+ = fixM (\ ~(_, new_binds) -> do
+ { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)
+ ; binds' <- zonkMonoBinds env1 binds
+ ; return (env1, binds') })
+
+---------------------------------------------
+zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc)
+zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
+
+zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc)
+zonk_lbind env = wrapLocM (zonk_bind env)
+
+zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc)
+zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss
+ , pat_ext = NPatBindTc fvs ty})
+ = do { (_env, new_pat) <- zonkPat env pat -- Env already extended
+ ; new_grhss <- zonkGRHSs env zonkLExpr grhss
+ ; new_ty <- zonkTcTypeToTypeX env ty
+ ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss
+ , pat_ext = NPatBindTc fvs new_ty }) }
+
+zonk_bind env (VarBind { var_ext = x
+ , var_id = var, var_rhs = expr })
+ = do { new_var <- zonkIdBndr env var
+ ; new_expr <- zonkLExpr env expr
+ ; return (VarBind { var_ext = x
+ , var_id = new_var
+ , var_rhs = new_expr }) }
+
+zonk_bind env bind@(FunBind { fun_id = L loc var
+ , fun_matches = ms
+ , fun_ext = co_fn })
+ = do { new_var <- zonkIdBndr env var
+ ; (env1, new_co_fn) <- zonkCoFn env co_fn
+ ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
+ ; return (bind { fun_id = L loc new_var
+ , fun_matches = new_ms
+ , fun_ext = new_co_fn }) }
+
+zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
+ , abs_ev_binds = ev_binds
+ , abs_exports = exports
+ , abs_binds = val_binds
+ , abs_sig = has_sig })
+ = ASSERT( all isImmutableTyVar tyvars )
+ do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
+ ; (env1, new_evs) <- zonkEvBndrsX env0 evs
+ ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
+ ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
+ do { let env3 = extendIdZonkEnvRec env2 $
+ collectHsBindsBinders new_val_binds
+ ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds
+ ; new_exports <- mapM (zonk_export env3) exports
+ ; return (new_val_binds, new_exports) }
+ ; return (AbsBinds { abs_ext = noExtField
+ , abs_tvs = new_tyvars, abs_ev_vars = new_evs
+ , abs_ev_binds = new_ev_binds
+ , abs_exports = new_exports, abs_binds = new_val_bind
+ , abs_sig = has_sig }) }
+ where
+ zonk_val_bind env lbind
+ | has_sig
+ , (L loc bind@(FunBind { fun_id = L mloc mono_id
+ , fun_matches = ms
+ , fun_ext = co_fn })) <- lbind
+ = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id
+ -- Specifically /not/ zonkIdBndr; we do not
+ -- want to complain about a levity-polymorphic binder
+ ; (env', new_co_fn) <- zonkCoFn env co_fn
+ ; new_ms <- zonkMatchGroup env' zonkLExpr ms
+ ; return $ L loc $
+ bind { fun_id = L mloc new_mono_id
+ , fun_matches = new_ms
+ , fun_ext = new_co_fn } }
+ | otherwise
+ = zonk_lbind env lbind -- The normal case
+
+ zonk_export env (ABE{ abe_ext = x
+ , abe_wrap = wrap
+ , abe_poly = poly_id
+ , abe_mono = mono_id
+ , abe_prags = prags })
+ = do new_poly_id <- zonkIdBndr env poly_id
+ (_, new_wrap) <- zonkCoFn env wrap
+ new_prags <- zonkSpecPrags env prags
+ return (ABE{ abe_ext = x
+ , abe_wrap = new_wrap
+ , abe_poly = new_poly_id
+ , abe_mono = zonkIdOcc env mono_id
+ , abe_prags = new_prags })
+ zonk_export _ (XABExport nec) = noExtCon nec
+
+zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id
+ , psb_args = details
+ , psb_def = lpat
+ , psb_dir = dir }))
+ = do { id' <- zonkIdBndr env id
+ ; (env1, lpat') <- zonkPat env lpat
+ ; let details' = zonkPatSynDetails env1 details
+ ; (_env2, dir') <- zonkPatSynDir env1 dir
+ ; return $ PatSynBind x $
+ bind { psb_id = L loc id'
+ , psb_args = details'
+ , psb_def = lpat'
+ , psb_dir = dir' } }
+
+zonk_bind _ (PatSynBind _ (XPatSynBind nec)) = noExtCon nec
+zonk_bind _ (XHsBindsLR nec) = noExtCon nec
+
+zonkPatSynDetails :: ZonkEnv
+ -> HsPatSynDetails (Located TcId)
+ -> HsPatSynDetails (Located Id)
+zonkPatSynDetails env (PrefixCon as)
+ = PrefixCon (map (zonkLIdOcc env) as)
+zonkPatSynDetails env (InfixCon a1 a2)
+ = InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2)
+zonkPatSynDetails env (RecCon flds)
+ = RecCon (map (fmap (zonkLIdOcc env)) flds)
+
+zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId
+ -> TcM (ZonkEnv, HsPatSynDir GhcTc)
+zonkPatSynDir env Unidirectional = return (env, Unidirectional)
+zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)
+zonkPatSynDir env (ExplicitBidirectional mg) = do
+ mg' <- zonkMatchGroup env zonkLExpr mg
+ return (env, ExplicitBidirectional mg')
+
+zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
+zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod
+zonkSpecPrags env (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags env ps
+ ; return (SpecPrags ps') }
+
+zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
+zonkLTcSpecPrags env ps
+ = mapM zonk_prag ps
+ where
+ zonk_prag (L loc (SpecPrag id co_fn inl))
+ = do { (_, co_fn') <- zonkCoFn env co_fn
+ ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
+
+{-
+************************************************************************
+* *
+\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
+* *
+************************************************************************
+-}
+
+zonkMatchGroup :: ZonkEnv
+ -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
+ -> MatchGroup GhcTcId (Located (body GhcTcId))
+ -> TcM (MatchGroup GhcTc (Located (body GhcTc)))
+zonkMatchGroup env zBody (MG { mg_alts = L l ms
+ , mg_ext = MatchGroupTc arg_tys res_ty
+ , mg_origin = origin })
+ = do { ms' <- mapM (zonkMatch env zBody) ms
+ ; arg_tys' <- zonkTcTypesToTypesX env arg_tys
+ ; res_ty' <- zonkTcTypeToTypeX env res_ty
+ ; return (MG { mg_alts = L l ms'
+ , mg_ext = MatchGroupTc arg_tys' res_ty'
+ , mg_origin = origin }) }
+zonkMatchGroup _ _ (XMatchGroup nec) = noExtCon nec
+
+zonkMatch :: ZonkEnv
+ -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
+ -> LMatch GhcTcId (Located (body GhcTcId))
+ -> TcM (LMatch GhcTc (Located (body GhcTc)))
+zonkMatch env zBody (L loc match@(Match { m_pats = pats
+ , m_grhss = grhss }))
+ = do { (env1, new_pats) <- zonkPats env pats
+ ; new_grhss <- zonkGRHSs env1 zBody grhss
+ ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
+zonkMatch _ _ (L _ (XMatch nec)) = noExtCon nec
+
+-------------------------------------------------------------------------
+zonkGRHSs :: ZonkEnv
+ -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
+ -> GRHSs GhcTcId (Located (body GhcTcId))
+ -> TcM (GRHSs GhcTc (Located (body GhcTc)))
+
+zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do
+ (new_env, new_binds) <- zonkLocalBinds env binds
+ let
+ zonk_grhs (GRHS xx guarded rhs)
+ = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
+ new_rhs <- zBody env2 rhs
+ return (GRHS xx new_guarded new_rhs)
+ zonk_grhs (XGRHS nec) = noExtCon nec
+ new_grhss <- mapM (wrapLocM zonk_grhs) grhss
+ return (GRHSs x new_grhss (L l new_binds))
+zonkGRHSs _ _ (XGRHSs nec) = noExtCon nec
+
+{-
+************************************************************************
+* *
+\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
+* *
+************************************************************************
+-}
+
+zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc]
+zonkLExpr :: ZonkEnv -> LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)
+zonkExpr :: ZonkEnv -> HsExpr GhcTcId -> TcM (HsExpr GhcTc)
+
+zonkLExprs env exprs = mapM (zonkLExpr env) exprs
+zonkLExpr env expr = wrapLocM (zonkExpr env) expr
+
+zonkExpr env (HsVar x (L l id))
+ = ASSERT2( isNothing (isDataConId_maybe id), ppr id )
+ return (HsVar x (L l (zonkIdOcc env id)))
+
+zonkExpr _ e@(HsConLikeOut {}) = return e
+
+zonkExpr _ (HsIPVar x id)
+ = return (HsIPVar x id)
+
+zonkExpr _ e@HsOverLabel{} = return e
+
+zonkExpr env (HsLit x (HsRat e f ty))
+ = do new_ty <- zonkTcTypeToTypeX env ty
+ return (HsLit x (HsRat e f new_ty))
+
+zonkExpr _ (HsLit x lit)
+ = return (HsLit x lit)
+
+zonkExpr env (HsOverLit x lit)
+ = do { lit' <- zonkOverLit env lit
+ ; return (HsOverLit x lit') }
+
+zonkExpr env (HsLam x matches)
+ = do new_matches <- zonkMatchGroup env zonkLExpr matches
+ return (HsLam x new_matches)
+
+zonkExpr env (HsLamCase x matches)
+ = do new_matches <- zonkMatchGroup env zonkLExpr matches
+ return (HsLamCase x new_matches)
+
+zonkExpr env (HsApp x e1 e2)
+ = do new_e1 <- zonkLExpr env e1
+ new_e2 <- zonkLExpr env e2
+ return (HsApp x new_e1 new_e2)
+
+zonkExpr env (HsAppType x e t)
+ = do new_e <- zonkLExpr env e
+ return (HsAppType x new_e t)
+ -- NB: the type is an HsType; can't zonk that!
+
+zonkExpr _ e@(HsRnBracketOut _ _ _)
+ = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)
+
+zonkExpr env (HsTcBracketOut x wrap body bs)
+ = do wrap' <- traverse zonkQuoteWrap wrap
+ bs' <- mapM (zonk_b env) bs
+ return (HsTcBracketOut x wrap' body bs')
+ where
+ zonkQuoteWrap (QuoteWrapper ev ty) = do
+ let ev' = zonkIdOcc env ev
+ ty' <- zonkTcTypeToTypeX env ty
+ return (QuoteWrapper ev' ty')
+
+ zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e
+ return (PendingTcSplice n e')
+
+zonkExpr env (HsSpliceE _ (XSplice (HsSplicedT s))) =
+ runTopSplice s >>= zonkExpr env
+
+zonkExpr _ e@(HsSpliceE _ _) = pprPanic "zonkExpr: HsSpliceE" (ppr e)
+
+zonkExpr env (OpApp fixity e1 op e2)
+ = do new_e1 <- zonkLExpr env e1
+ new_op <- zonkLExpr env op
+ new_e2 <- zonkLExpr env e2
+ return (OpApp fixity new_e1 new_op new_e2)
+
+zonkExpr env (NegApp x expr op)
+ = do (env', new_op) <- zonkSyntaxExpr env op
+ new_expr <- zonkLExpr env' expr
+ return (NegApp x new_expr new_op)
+
+zonkExpr env (HsPar x e)
+ = do new_e <- zonkLExpr env e
+ return (HsPar x new_e)
+
+zonkExpr env (SectionL x expr op)
+ = do new_expr <- zonkLExpr env expr
+ new_op <- zonkLExpr env op
+ return (SectionL x new_expr new_op)
+
+zonkExpr env (SectionR x op expr)
+ = do new_op <- zonkLExpr env op
+ new_expr <- zonkLExpr env expr
+ return (SectionR x new_op new_expr)
+
+zonkExpr env (ExplicitTuple x tup_args boxed)
+ = do { new_tup_args <- mapM zonk_tup_arg tup_args
+ ; return (ExplicitTuple x new_tup_args boxed) }
+ where
+ zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e
+ ; return (L l (Present x e')) }
+ zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t
+ ; return (L l (Missing t')) }
+ zonk_tup_arg (L _ (XTupArg nec)) = noExtCon nec
+
+
+zonkExpr env (ExplicitSum args alt arity expr)
+ = do new_args <- mapM (zonkTcTypeToTypeX env) args
+ new_expr <- zonkLExpr env expr
+ return (ExplicitSum new_args alt arity new_expr)
+
+zonkExpr env (HsCase x expr ms)
+ = do new_expr <- zonkLExpr env expr
+ new_ms <- zonkMatchGroup env zonkLExpr ms
+ return (HsCase x new_expr new_ms)
+
+zonkExpr env (HsIf x fun e1 e2 e3)
+ = do (env1, new_fun) <- zonkSyntaxExpr env fun
+ new_e1 <- zonkLExpr env1 e1
+ new_e2 <- zonkLExpr env1 e2
+ new_e3 <- zonkLExpr env1 e3
+ return (HsIf x new_fun new_e1 new_e2 new_e3)
+
+zonkExpr env (HsMultiIf ty alts)
+ = do { alts' <- mapM (wrapLocM zonk_alt) alts
+ ; ty' <- zonkTcTypeToTypeX env ty
+ ; return $ HsMultiIf ty' alts' }
+ where zonk_alt (GRHS x guard expr)
+ = do { (env', guard') <- zonkStmts env zonkLExpr guard
+ ; expr' <- zonkLExpr env' expr
+ ; return $ GRHS x guard' expr' }
+ zonk_alt (XGRHS nec) = noExtCon nec
+
+zonkExpr env (HsLet x (L l binds) expr)
+ = do (new_env, new_binds) <- zonkLocalBinds env binds
+ new_expr <- zonkLExpr new_env expr
+ return (HsLet x (L l new_binds) new_expr)
+
+zonkExpr env (HsDo ty do_or_lc (L l stmts))
+ = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
+ new_ty <- zonkTcTypeToTypeX env ty
+ return (HsDo new_ty do_or_lc (L l new_stmts))
+
+zonkExpr env (ExplicitList ty wit exprs)
+ = do (env1, new_wit) <- zonkWit env wit
+ new_ty <- zonkTcTypeToTypeX env1 ty
+ new_exprs <- zonkLExprs env1 exprs
+ return (ExplicitList new_ty new_wit new_exprs)
+ where zonkWit env Nothing = return (env, Nothing)
+ zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
+
+zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds })
+ = do { new_con_expr <- zonkExpr env (rcon_con_expr ext)
+ ; new_rbinds <- zonkRecFields env rbinds
+ ; return (expr { rcon_ext = ext { rcon_con_expr = new_con_expr }
+ , rcon_flds = new_rbinds }) }
+
+zonkExpr env (RecordUpd { rupd_flds = rbinds
+ , rupd_expr = expr
+ , rupd_ext = RecordUpdTc
+ { rupd_cons = cons, rupd_in_tys = in_tys
+ , rupd_out_tys = out_tys, rupd_wrap = req_wrap }})
+ = do { new_expr <- zonkLExpr env expr
+ ; new_in_tys <- mapM (zonkTcTypeToTypeX env) in_tys
+ ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys
+ ; new_rbinds <- zonkRecUpdFields env rbinds
+ ; (_, new_recwrap) <- zonkCoFn env req_wrap
+ ; return (RecordUpd { rupd_expr = new_expr, rupd_flds = new_rbinds
+ , rupd_ext = RecordUpdTc
+ { rupd_cons = cons, rupd_in_tys = new_in_tys
+ , rupd_out_tys = new_out_tys
+ , rupd_wrap = new_recwrap }}) }
+
+zonkExpr env (ExprWithTySig _ e ty)
+ = do { e' <- zonkLExpr env e
+ ; return (ExprWithTySig noExtField e' ty) }
+
+zonkExpr env (ArithSeq expr wit info)
+ = do (env1, new_wit) <- zonkWit env wit
+ new_expr <- zonkExpr env expr
+ new_info <- zonkArithSeq env1 info
+ return (ArithSeq new_expr new_wit new_info)
+ where zonkWit env Nothing = return (env, Nothing)
+ zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
+
+zonkExpr env (HsPragE x prag expr)
+ = do new_expr <- zonkLExpr env expr
+ return (HsPragE x prag new_expr)
+
+-- arrow notation extensions
+zonkExpr env (HsProc x pat body)
+ = do { (env1, new_pat) <- zonkPat env pat
+ ; new_body <- zonkCmdTop env1 body
+ ; return (HsProc x new_pat new_body) }
+
+-- StaticPointers extension
+zonkExpr env (HsStatic fvs expr)
+ = HsStatic fvs <$> zonkLExpr env expr
+
+zonkExpr env (XExpr (HsWrap co_fn expr))
+ = do (env1, new_co_fn) <- zonkCoFn env co_fn
+ new_expr <- zonkExpr env1 expr
+ return (XExpr (HsWrap new_co_fn new_expr))
+
+zonkExpr _ e@(HsUnboundVar {})
+ = return e
+
+zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
+
+-------------------------------------------------------------------------
+{-
+Note [Skolems in zonkSyntaxExpr]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider rebindable syntax with something like
+
+ (>>=) :: (forall x. blah) -> (forall y. blah') -> blah''
+
+The x and y become skolems that are in scope when type-checking the
+arguments to the bind. This means that we must extend the ZonkEnv with
+these skolems when zonking the arguments to the bind. But the skolems
+are different between the two arguments, and so we should theoretically
+carry around different environments to use for the different arguments.
+
+However, this becomes a logistical nightmare, especially in dealing with
+the more exotic Stmt forms. So, we simplify by making the critical
+assumption that the uniques of the skolems are different. (This assumption
+is justified by the use of newUnique in GHC.Tc.Utils.TcMType.instSkolTyCoVarX.)
+Now, we can safely just extend one environment.
+-}
+
+-- See Note [Skolems in zonkSyntaxExpr]
+zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTcId
+ -> TcM (ZonkEnv, SyntaxExpr GhcTc)
+zonkSyntaxExpr env (SyntaxExprTc { syn_expr = expr
+ , syn_arg_wraps = arg_wraps
+ , syn_res_wrap = res_wrap })
+ = do { (env0, res_wrap') <- zonkCoFn env res_wrap
+ ; expr' <- zonkExpr env0 expr
+ ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps
+ ; return (env1, SyntaxExprTc { syn_expr = expr'
+ , syn_arg_wraps = arg_wraps'
+ , syn_res_wrap = res_wrap' }) }
+zonkSyntaxExpr env NoSyntaxExprTc = return (env, NoSyntaxExprTc)
+
+-------------------------------------------------------------------------
+
+zonkLCmd :: ZonkEnv -> LHsCmd GhcTcId -> TcM (LHsCmd GhcTc)
+zonkCmd :: ZonkEnv -> HsCmd GhcTcId -> TcM (HsCmd GhcTc)
+
+zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd
+
+zonkCmd env (XCmd (HsWrap w cmd))
+ = do { (env1, w') <- zonkCoFn env w
+ ; cmd' <- zonkCmd env1 cmd
+ ; return (XCmd (HsWrap w' cmd')) }
+zonkCmd env (HsCmdArrApp ty e1 e2 ho rl)
+ = do new_e1 <- zonkLExpr env e1
+ new_e2 <- zonkLExpr env e2
+ new_ty <- zonkTcTypeToTypeX env ty
+ return (HsCmdArrApp new_ty new_e1 new_e2 ho rl)
+
+zonkCmd env (HsCmdArrForm x op f fixity args)
+ = do new_op <- zonkLExpr env op
+ new_args <- mapM (zonkCmdTop env) args
+ return (HsCmdArrForm x new_op f fixity new_args)
+
+zonkCmd env (HsCmdApp x c e)
+ = do new_c <- zonkLCmd env c
+ new_e <- zonkLExpr env e
+ return (HsCmdApp x new_c new_e)
+
+zonkCmd env (HsCmdLam x matches)
+ = do new_matches <- zonkMatchGroup env zonkLCmd matches
+ return (HsCmdLam x new_matches)
+
+zonkCmd env (HsCmdPar x c)
+ = do new_c <- zonkLCmd env c
+ return (HsCmdPar x new_c)
+
+zonkCmd env (HsCmdCase x expr ms)
+ = do new_expr <- zonkLExpr env expr
+ new_ms <- zonkMatchGroup env zonkLCmd ms
+ return (HsCmdCase x new_expr new_ms)
+
+zonkCmd env (HsCmdIf x eCond ePred cThen cElse)
+ = do { (env1, new_eCond) <- zonkSyntaxExpr env eCond
+ ; new_ePred <- zonkLExpr env1 ePred
+ ; new_cThen <- zonkLCmd env1 cThen
+ ; new_cElse <- zonkLCmd env1 cElse
+ ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) }
+
+zonkCmd env (HsCmdLet x (L l binds) cmd)
+ = do (new_env, new_binds) <- zonkLocalBinds env binds
+ new_cmd <- zonkLCmd new_env cmd
+ return (HsCmdLet x (L l new_binds) new_cmd)
+
+zonkCmd env (HsCmdDo ty (L l stmts))
+ = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
+ new_ty <- zonkTcTypeToTypeX env ty
+ return (HsCmdDo new_ty (L l new_stmts))
+
+
+
+zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTcId -> TcM (LHsCmdTop GhcTc)
+zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
+
+zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTcId -> TcM (HsCmdTop GhcTc)
+zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)
+ = do new_cmd <- zonkLCmd env cmd
+ new_stack_tys <- zonkTcTypeToTypeX env stack_tys
+ new_ty <- zonkTcTypeToTypeX env ty
+ new_ids <- mapSndM (zonkExpr env) ids
+
+ MASSERT( isLiftedTypeKind (tcTypeKind new_stack_tys) )
+ -- desugarer assumes that this is not levity polymorphic...
+ -- but indeed it should always be lifted due to the typing
+ -- rules for arrows
+
+ return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd)
+zonk_cmd_top _ (XCmdTop nec) = noExtCon nec
+
+-------------------------------------------------------------------------
+zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
+zonkCoFn env WpHole = return (env, WpHole)
+zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
+ ; (env2, c2') <- zonkCoFn env1 c2
+ ; return (env2, WpCompose c1' c2') }
+zonkCoFn env (WpFun c1 c2 t1 d) = do { (env1, c1') <- zonkCoFn env c1
+ ; (env2, c2') <- zonkCoFn env1 c2
+ ; t1' <- zonkTcTypeToTypeX env2 t1
+ ; return (env2, WpFun c1' c2' t1' d) }
+zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co
+ ; return (env, WpCast co') }
+zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev
+ ; return (env', WpEvLam ev') }
+zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg
+ ; return (env, WpEvApp arg') }
+zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv )
+ do { (env', tv') <- zonkTyBndrX env tv
+ ; return (env', WpTyLam tv') }
+zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToTypeX env ty
+ ; return (env, WpTyApp ty') }
+zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs
+ ; return (env1, WpLet bs') }
+
+-------------------------------------------------------------------------
+zonkOverLit :: ZonkEnv -> HsOverLit GhcTcId -> TcM (HsOverLit GhcTc)
+zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e })
+ = do { ty' <- zonkTcTypeToTypeX env ty
+ ; e' <- zonkExpr env e
+ ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) }
+
+zonkOverLit _ (XOverLit nec) = noExtCon nec
+
+-------------------------------------------------------------------------
+zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> TcM (ArithSeqInfo GhcTc)
+
+zonkArithSeq env (From e)
+ = do new_e <- zonkLExpr env e
+ return (From new_e)
+
+zonkArithSeq env (FromThen e1 e2)
+ = do new_e1 <- zonkLExpr env e1
+ new_e2 <- zonkLExpr env e2
+ return (FromThen new_e1 new_e2)
+
+zonkArithSeq env (FromTo e1 e2)
+ = do new_e1 <- zonkLExpr env e1
+ new_e2 <- zonkLExpr env e2
+ return (FromTo new_e1 new_e2)
+
+zonkArithSeq env (FromThenTo e1 e2 e3)
+ = do new_e1 <- zonkLExpr env e1
+ new_e2 <- zonkLExpr env e2
+ new_e3 <- zonkLExpr env e3
+ return (FromThenTo new_e1 new_e2 new_e3)
+
+
+-------------------------------------------------------------------------
+zonkStmts :: ZonkEnv
+ -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
+ -> [LStmt GhcTcId (Located (body GhcTcId))]
+ -> TcM (ZonkEnv, [LStmt GhcTc (Located (body GhcTc))])
+zonkStmts env _ [] = return (env, [])
+zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s
+ ; (env2, ss') <- zonkStmts env1 zBody ss
+ ; return (env2, s' : ss') }
+
+zonkStmt :: ZonkEnv
+ -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
+ -> Stmt GhcTcId (Located (body GhcTcId))
+ -> TcM (ZonkEnv, Stmt GhcTc (Located (body GhcTc)))
+zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op)
+ = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op
+ ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty
+ ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs
+ ; let new_binders = [b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs
+ , b <- bs]
+ env2 = extendIdZonkEnvRec env1 new_binders
+ ; new_mzip <- zonkExpr env2 mzip_op
+ ; return (env2
+ , ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)}
+ where
+ zonk_branch env1 (ParStmtBlock x stmts bndrs return_op)
+ = do { (env2, new_stmts) <- zonkStmts env1 zonkLExpr stmts
+ ; (env3, new_return) <- zonkSyntaxExpr env2 return_op
+ ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs)
+ new_return) }
+ zonk_branch _ (XParStmtBlock nec) = noExtCon nec
+
+zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
+ , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id
+ , recS_bind_fn = bind_id
+ , recS_ext =
+ RecStmtTc { recS_bind_ty = bind_ty
+ , recS_later_rets = later_rets
+ , recS_rec_rets = rec_rets
+ , recS_ret_ty = ret_ty} })
+ = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id
+ ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id
+ ; (env3, new_ret_id) <- zonkSyntaxExpr env2 ret_id
+ ; new_bind_ty <- zonkTcTypeToTypeX env3 bind_ty
+ ; new_rvs <- zonkIdBndrs env3 rvs
+ ; new_lvs <- zonkIdBndrs env3 lvs
+ ; new_ret_ty <- zonkTcTypeToTypeX env3 ret_ty
+ ; let env4 = extendIdZonkEnvRec env3 new_rvs
+ ; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts
+ -- Zonk the ret-expressions in an envt that
+ -- has the polymorphic bindings in the envt
+ ; new_later_rets <- mapM (zonkExpr env5) later_rets
+ ; new_rec_rets <- mapM (zonkExpr env5) rec_rets
+ ; return (extendIdZonkEnvRec env3 new_lvs, -- Only the lvs are needed
+ RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
+ , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
+ , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
+ , recS_ext = RecStmtTc
+ { recS_bind_ty = new_bind_ty
+ , recS_later_rets = new_later_rets
+ , recS_rec_rets = new_rec_rets
+ , recS_ret_ty = new_ret_ty } }) }
+
+zonkStmt env zBody (BodyStmt ty body then_op guard_op)
+ = do (env1, new_then_op) <- zonkSyntaxExpr env then_op
+ (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op
+ new_body <- zBody env2 body
+ new_ty <- zonkTcTypeToTypeX env2 ty
+ return (env2, BodyStmt new_ty new_body new_then_op new_guard_op)
+
+zonkStmt env zBody (LastStmt x body noret ret_op)
+ = do (env1, new_ret) <- zonkSyntaxExpr env ret_op
+ new_body <- zBody env1 body
+ return (env, LastStmt x new_body noret new_ret)
+
+zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
+ , trS_by = by, trS_form = form, trS_using = using
+ , trS_ret = return_op, trS_bind = bind_op
+ , trS_ext = bind_arg_ty
+ , trS_fmap = liftM_op })
+ = do {
+ ; (env1, bind_op') <- zonkSyntaxExpr env bind_op
+ ; bind_arg_ty' <- zonkTcTypeToTypeX env1 bind_arg_ty
+ ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts
+ ; by' <- fmapMaybeM (zonkLExpr env2) by
+ ; using' <- zonkLExpr env2 using
+
+ ; (env3, return_op') <- zonkSyntaxExpr env2 return_op
+ ; binderMap' <- mapM (zonkBinderMapEntry env3) binderMap
+ ; liftM_op' <- zonkExpr env3 liftM_op
+ ; let env3' = extendIdZonkEnvRec env3 (map snd binderMap')
+ ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
+ , trS_by = by', trS_form = form, trS_using = using'
+ , trS_ret = return_op', trS_bind = bind_op'
+ , trS_ext = bind_arg_ty'
+ , trS_fmap = liftM_op' }) }
+ where
+ zonkBinderMapEntry env (oldBinder, newBinder) = do
+ let oldBinder' = zonkIdOcc env oldBinder
+ newBinder' <- zonkIdBndr env newBinder
+ return (oldBinder', newBinder')
+
+zonkStmt env _ (LetStmt x (L l binds))
+ = do (env1, new_binds) <- zonkLocalBinds env binds
+ return (env1, LetStmt x (L l new_binds))
+
+zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op)
+ = do { (env1, new_bind) <- zonkSyntaxExpr env bind_op
+ ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty
+ ; new_body <- zBody env1 body
+ ; (env2, new_pat) <- zonkPat env1 pat
+ ; (_, new_fail) <- zonkSyntaxExpr env1 fail_op
+ ; return ( env2
+ , BindStmt new_bind_ty new_pat new_body new_bind new_fail) }
+
+-- Scopes: join > ops (in reverse order) > pats (in forward order)
+-- > rest of stmts
+zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
+ = do { (env1, new_mb_join) <- zonk_join env mb_join
+ ; (env2, new_args) <- zonk_args env1 args
+ ; new_body_ty <- zonkTcTypeToTypeX env2 body_ty
+ ; return ( env2
+ , ApplicativeStmt new_body_ty new_args new_mb_join) }
+ where
+ zonk_join env Nothing = return (env, Nothing)
+ zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j
+
+ get_pat (_, ApplicativeArgOne _ pat _ _ _) = pat
+ get_pat (_, ApplicativeArgMany _ _ _ pat) = pat
+ get_pat (_, XApplicativeArg nec) = noExtCon nec
+
+ replace_pat pat (op, ApplicativeArgOne x _ a isBody fail_op)
+ = (op, ApplicativeArgOne x pat a isBody fail_op)
+ replace_pat pat (op, ApplicativeArgMany x a b _)
+ = (op, ApplicativeArgMany x a b pat)
+ replace_pat _ (_, XApplicativeArg nec) = noExtCon nec
+
+ zonk_args env args
+ = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args)
+ ; (env2, new_pats) <- zonkPats env1 (map get_pat args)
+ ; return (env2, zipWith replace_pat new_pats (reverse new_args_rev)) }
+
+ -- these need to go backward, because if any operators are higher-rank,
+ -- later operators may introduce skolems that are in scope for earlier
+ -- arguments
+ zonk_args_rev env ((op, arg) : args)
+ = do { (env1, new_op) <- zonkSyntaxExpr env op
+ ; new_arg <- zonk_arg env1 arg
+ ; (env2, new_args) <- zonk_args_rev env1 args
+ ; return (env2, (new_op, new_arg) : new_args) }
+ zonk_args_rev env [] = return (env, [])
+
+ zonk_arg env (ApplicativeArgOne x pat expr isBody fail_op)
+ = do { new_expr <- zonkLExpr env expr
+ ; (_, new_fail) <- zonkSyntaxExpr env fail_op
+ ; return (ApplicativeArgOne x pat new_expr isBody new_fail) }
+ zonk_arg env (ApplicativeArgMany x stmts ret pat)
+ = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
+ ; new_ret <- zonkExpr env1 ret
+ ; return (ApplicativeArgMany x new_stmts new_ret pat) }
+ zonk_arg _ (XApplicativeArg nec) = noExtCon nec
+
+zonkStmt _ _ (XStmtLR nec) = noExtCon nec
+
+-------------------------------------------------------------------------
+zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId)
+zonkRecFields env (HsRecFields flds dd)
+ = do { flds' <- mapM zonk_rbind flds
+ ; return (HsRecFields flds' dd) }
+ where
+ zonk_rbind (L l fld)
+ = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld)
+ ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
+ ; return (L l (fld { hsRecFieldLbl = new_id
+ , hsRecFieldArg = new_expr })) }
+
+zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTcId]
+ -> TcM [LHsRecUpdField GhcTcId]
+zonkRecUpdFields env = mapM zonk_rbind
+ where
+ zonk_rbind (L l fld)
+ = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld)
+ ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
+ ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id
+ , hsRecFieldArg = new_expr })) }
+
+-------------------------------------------------------------------------
+mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a
+ -> TcM (Either (Located HsIPName) b)
+mapIPNameTc _ (Left x) = return (Left x)
+mapIPNameTc f (Right x) = do r <- f x
+ return (Right r)
+
+{-
+************************************************************************
+* *
+\subsection[BackSubst-Pats]{Patterns}
+* *
+************************************************************************
+-}
+
+zonkPat :: ZonkEnv -> OutPat GhcTcId -> TcM (ZonkEnv, OutPat GhcTc)
+-- Extend the environment as we go, because it's possible for one
+-- pattern to bind something that is used in another (inside or
+-- to the right)
+zonkPat env pat = wrapLocSndM (zonk_pat env) pat
+
+zonk_pat :: ZonkEnv -> Pat GhcTcId -> TcM (ZonkEnv, Pat GhcTc)
+zonk_pat env (ParPat x p)
+ = do { (env', p') <- zonkPat env p
+ ; return (env', ParPat x p') }
+
+zonk_pat env (WildPat ty)
+ = do { ty' <- zonkTcTypeToTypeX env ty
+ ; ensureNotLevPoly ty'
+ (text "In a wildcard pattern")
+ ; return (env, WildPat ty') }
+
+zonk_pat env (VarPat x (L l v))
+ = do { v' <- zonkIdBndr env v
+ ; return (extendIdZonkEnv env v', VarPat x (L l v')) }
+
+zonk_pat env (LazyPat x pat)
+ = do { (env', pat') <- zonkPat env pat
+ ; return (env', LazyPat x pat') }
+
+zonk_pat env (BangPat x pat)
+ = do { (env', pat') <- zonkPat env pat
+ ; return (env', BangPat x pat') }
+
+zonk_pat env (AsPat x (L loc v) pat)
+ = do { v' <- zonkIdBndr env v
+ ; (env', pat') <- zonkPat (extendIdZonkEnv env v') pat
+ ; return (env', AsPat x (L loc v') pat') }
+
+zonk_pat env (ViewPat ty expr pat)
+ = do { expr' <- zonkLExpr env expr
+ ; (env', pat') <- zonkPat env pat
+ ; ty' <- zonkTcTypeToTypeX env ty
+ ; return (env', ViewPat ty' expr' pat') }
+
+zonk_pat env (ListPat (ListPatTc ty Nothing) pats)
+ = do { ty' <- zonkTcTypeToTypeX env ty
+ ; (env', pats') <- zonkPats env pats
+ ; return (env', ListPat (ListPatTc ty' Nothing) pats') }
+
+zonk_pat env (ListPat (ListPatTc ty (Just (ty2,wit))) pats)
+ = do { (env', wit') <- zonkSyntaxExpr env wit
+ ; ty2' <- zonkTcTypeToTypeX env' ty2
+ ; ty' <- zonkTcTypeToTypeX env' ty
+ ; (env'', pats') <- zonkPats env' pats
+ ; return (env'', ListPat (ListPatTc ty' (Just (ty2',wit'))) pats') }
+
+zonk_pat env (TuplePat tys pats boxed)
+ = do { tys' <- mapM (zonkTcTypeToTypeX env) tys
+ ; (env', pats') <- zonkPats env pats
+ ; return (env', TuplePat tys' pats' boxed) }
+
+zonk_pat env (SumPat tys pat alt arity )
+ = do { tys' <- mapM (zonkTcTypeToTypeX env) tys
+ ; (env', pat') <- zonkPat env pat
+ ; return (env', SumPat tys' pat' alt arity) }
+
+zonk_pat env p@(ConPatOut { pat_arg_tys = tys
+ , pat_tvs = tyvars
+ , pat_dicts = evs
+ , pat_binds = binds
+ , pat_args = args
+ , pat_wrap = wrapper
+ , pat_con = L _ con })
+ = ASSERT( all isImmutableTyVar tyvars )
+ do { new_tys <- mapM (zonkTcTypeToTypeX env) tys
+
+ -- an unboxed tuple pattern (but only an unboxed tuple pattern)
+ -- might have levity-polymorphic arguments. Check for this badness.
+ ; case con of
+ RealDataCon dc
+ | isUnboxedTupleTyCon (dataConTyCon dc)
+ -> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys)
+ _ -> return ()
+
+ ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars
+ -- Must zonk the existential variables, because their
+ -- /kind/ need potential zonking.
+ -- cf typecheck/should_compile/tc221.hs
+ ; (env1, new_evs) <- zonkEvBndrsX env0 evs
+ ; (env2, new_binds) <- zonkTcEvBinds env1 binds
+ ; (env3, new_wrapper) <- zonkCoFn env2 wrapper
+ ; (env', new_args) <- zonkConStuff env3 args
+ ; return (env', p { pat_arg_tys = new_tys,
+ pat_tvs = new_tyvars,
+ pat_dicts = new_evs,
+ pat_binds = new_binds,
+ pat_args = new_args,
+ pat_wrap = new_wrapper}) }
+ where
+ doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p
+
+zonk_pat env (LitPat x lit) = return (env, LitPat x lit)
+
+zonk_pat env (SigPat ty pat hs_ty)
+ = do { ty' <- zonkTcTypeToTypeX env ty
+ ; (env', pat') <- zonkPat env pat
+ ; return (env', SigPat ty' pat' hs_ty) }
+
+zonk_pat env (NPat ty (L l lit) mb_neg eq_expr)
+ = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr
+ ; (env2, mb_neg') <- case mb_neg of
+ Nothing -> return (env1, Nothing)
+ Just n -> second Just <$> zonkSyntaxExpr env1 n
+
+ ; lit' <- zonkOverLit env2 lit
+ ; ty' <- zonkTcTypeToTypeX env2 ty
+ ; return (env2, NPat ty' (L l lit') mb_neg' eq_expr') }
+
+zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2)
+ = do { (env1, e1') <- zonkSyntaxExpr env e1
+ ; (env2, e2') <- zonkSyntaxExpr env1 e2
+ ; n' <- zonkIdBndr env2 n
+ ; lit1' <- zonkOverLit env2 lit1
+ ; lit2' <- zonkOverLit env2 lit2
+ ; ty' <- zonkTcTypeToTypeX env2 ty
+ ; return (extendIdZonkEnv env2 n',
+ NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') }
+
+zonk_pat env (CoPat x co_fn pat ty)
+ = do { (env', co_fn') <- zonkCoFn env co_fn
+ ; (env'', pat') <- zonkPat env' (noLoc pat)
+ ; ty' <- zonkTcTypeToTypeX env'' ty
+ ; return (env'', CoPat x co_fn' (unLoc pat') ty') }
+
+zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
+
+---------------------------
+zonkConStuff :: ZonkEnv
+ -> HsConDetails (OutPat GhcTcId) (HsRecFields id (OutPat GhcTcId))
+ -> TcM (ZonkEnv,
+ HsConDetails (OutPat GhcTc) (HsRecFields id (OutPat GhcTc)))
+zonkConStuff env (PrefixCon pats)
+ = do { (env', pats') <- zonkPats env pats
+ ; return (env', PrefixCon pats') }
+
+zonkConStuff env (InfixCon p1 p2)
+ = do { (env1, p1') <- zonkPat env p1
+ ; (env', p2') <- zonkPat env1 p2
+ ; return (env', InfixCon p1' p2') }
+
+zonkConStuff env (RecCon (HsRecFields rpats dd))
+ = do { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats)
+ ; let rpats' = zipWith (\(L l rp) p' ->
+ L l (rp { hsRecFieldArg = p' }))
+ rpats pats'
+ ; return (env', RecCon (HsRecFields rpats' dd)) }
+ -- Field selectors have declared types; hence no zonking
+
+---------------------------
+zonkPats :: ZonkEnv -> [OutPat GhcTcId] -> TcM (ZonkEnv, [OutPat GhcTc])
+zonkPats env [] = return (env, [])
+zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
+ ; (env', pats') <- zonkPats env1 pats
+ ; return (env', pat':pats') }
+
+{-
+************************************************************************
+* *
+\subsection[BackSubst-Foreign]{Foreign exports}
+* *
+************************************************************************
+-}
+
+zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTcId]
+ -> TcM [LForeignDecl GhcTc]
+zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls
+
+zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTcId -> TcM (ForeignDecl GhcTc)
+zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co
+ , fd_fe = spec })
+ = return (ForeignExport { fd_name = zonkLIdOcc env i
+ , fd_sig_ty = undefined, fd_e_ext = co
+ , fd_fe = spec })
+zonkForeignExport _ for_imp
+ = return for_imp -- Foreign imports don't need zonking
+
+zonkRules :: ZonkEnv -> [LRuleDecl GhcTcId] -> TcM [LRuleDecl GhcTc]
+zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs
+
+zonkRule :: ZonkEnv -> RuleDecl GhcTcId -> TcM (RuleDecl GhcTc)
+zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-}
+ , rd_lhs = lhs
+ , rd_rhs = rhs })
+ = do { (env_inside, new_tm_bndrs) <- mapAccumLM zonk_tm_bndr env tm_bndrs
+
+ ; let env_lhs = setZonkType env_inside SkolemiseFlexi
+ -- See Note [Zonking the LHS of a RULE]
+
+ ; new_lhs <- zonkLExpr env_lhs lhs
+ ; new_rhs <- zonkLExpr env_inside rhs
+
+ ; return $ rule { rd_tmvs = new_tm_bndrs
+ , rd_lhs = new_lhs
+ , rd_rhs = new_rhs } }
+ where
+ zonk_tm_bndr env (L l (RuleBndr x (L loc v)))
+ = do { (env', v') <- zonk_it env v
+ ; return (env', L l (RuleBndr x (L loc v'))) }
+ zonk_tm_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig"
+ zonk_tm_bndr _ (L _ (XRuleBndr nec)) = noExtCon nec
+
+ zonk_it env v
+ | isId v = do { v' <- zonkIdBndr env v
+ ; return (extendIdZonkEnvRec env [v'], v') }
+ | otherwise = ASSERT( isImmutableTyVar v)
+ zonkTyBndrX env v
+ -- DV: used to be return (env,v) but that is plain
+ -- wrong because we may need to go inside the kind
+ -- of v and zonk there!
+zonkRule _ (XRuleDecl nec) = noExtCon nec
+
+{-
+************************************************************************
+* *
+ Constraints and evidence
+* *
+************************************************************************
+-}
+
+zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
+zonkEvTerm env (EvExpr e)
+ = EvExpr <$> zonkCoreExpr env e
+zonkEvTerm env (EvTypeable ty ev)
+ = EvTypeable <$> zonkTcTypeToTypeX env ty <*> zonkEvTypeable env ev
+zonkEvTerm env (EvFun { et_tvs = tvs, et_given = evs
+ , et_binds = ev_binds, et_body = body_id })
+ = do { (env0, new_tvs) <- zonkTyBndrsX env tvs
+ ; (env1, new_evs) <- zonkEvBndrsX env0 evs
+ ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
+ ; let new_body_id = zonkIdOcc env2 body_id
+ ; return (EvFun { et_tvs = new_tvs, et_given = new_evs
+ , et_binds = new_ev_binds, et_body = new_body_id }) }
+
+zonkCoreExpr :: ZonkEnv -> CoreExpr -> TcM CoreExpr
+zonkCoreExpr env (Var v)
+ | isCoVar v
+ = Coercion <$> zonkCoVarOcc env v
+ | otherwise
+ = return (Var $ zonkIdOcc env v)
+zonkCoreExpr _ (Lit l)
+ = return $ Lit l
+zonkCoreExpr env (Coercion co)
+ = Coercion <$> zonkCoToCo env co
+zonkCoreExpr env (Type ty)
+ = Type <$> zonkTcTypeToTypeX env ty
+
+zonkCoreExpr env (Cast e co)
+ = Cast <$> zonkCoreExpr env e <*> zonkCoToCo env co
+zonkCoreExpr env (Tick t e)
+ = Tick t <$> zonkCoreExpr env e -- Do we need to zonk in ticks?
+
+zonkCoreExpr env (App e1 e2)
+ = App <$> zonkCoreExpr env e1 <*> zonkCoreExpr env e2
+zonkCoreExpr env (Lam v e)
+ = do { (env1, v') <- zonkCoreBndrX env v
+ ; Lam v' <$> zonkCoreExpr env1 e }
+zonkCoreExpr env (Let bind e)
+ = do (env1, bind') <- zonkCoreBind env bind
+ Let bind'<$> zonkCoreExpr env1 e
+zonkCoreExpr env (Case scrut b ty alts)
+ = do scrut' <- zonkCoreExpr env scrut
+ ty' <- zonkTcTypeToTypeX env ty
+ b' <- zonkIdBndr env b
+ let env1 = extendIdZonkEnv env b'
+ alts' <- mapM (zonkCoreAlt env1) alts
+ return $ Case scrut' b' ty' alts'
+
+zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt
+zonkCoreAlt env (dc, bndrs, rhs)
+ = do (env1, bndrs') <- zonkCoreBndrsX env bndrs
+ rhs' <- zonkCoreExpr env1 rhs
+ return $ (dc, bndrs', rhs')
+
+zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind)
+zonkCoreBind env (NonRec v e)
+ = do v' <- zonkIdBndr env v
+ e' <- zonkCoreExpr env e
+ let env1 = extendIdZonkEnv env v'
+ return (env1, NonRec v' e')
+zonkCoreBind env (Rec pairs)
+ = do (env1, pairs') <- fixM go
+ return (env1, Rec pairs')
+ where
+ go ~(_, new_pairs) = do
+ let env1 = extendIdZonkEnvRec env (map fst new_pairs)
+ pairs' <- mapM (zonkCorePair env1) pairs
+ return (env1, pairs')
+
+zonkCorePair :: ZonkEnv -> (CoreBndr, CoreExpr) -> TcM (CoreBndr, CoreExpr)
+zonkCorePair env (v,e) = (,) <$> zonkIdBndr env v <*> zonkCoreExpr env e
+
+zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
+zonkEvTypeable env (EvTypeableTyCon tycon e)
+ = do { e' <- mapM (zonkEvTerm env) e
+ ; return $ EvTypeableTyCon tycon e' }
+zonkEvTypeable env (EvTypeableTyApp t1 t2)
+ = do { t1' <- zonkEvTerm env t1
+ ; t2' <- zonkEvTerm env t2
+ ; return (EvTypeableTyApp t1' t2') }
+zonkEvTypeable env (EvTypeableTrFun t1 t2)
+ = do { t1' <- zonkEvTerm env t1
+ ; t2' <- zonkEvTerm env t2
+ ; return (EvTypeableTrFun t1' t2') }
+zonkEvTypeable env (EvTypeableTyLit t1)
+ = do { t1' <- zonkEvTerm env t1
+ ; return (EvTypeableTyLit t1') }
+
+zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])
+zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs
+ ; return (env, [EvBinds (unionManyBags bs')]) }
+
+zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
+zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs
+ ; return (env', EvBinds bs') }
+
+zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind)
+zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var
+zonk_tc_ev_binds env (EvBinds bs) = zonkEvBinds env bs
+
+zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
+zonkEvBindsVar env (EvBindsVar { ebv_binds = ref })
+ = do { bs <- readMutVar ref
+ ; zonkEvBinds env (evBindMapBinds bs) }
+zonkEvBindsVar env (CoEvBindsVar {}) = return (env, emptyBag)
+
+zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
+zonkEvBinds env binds
+ = {-# SCC "zonkEvBinds" #-}
+ fixM (\ ~( _, new_binds) -> do
+ { let env1 = extendIdZonkEnvRec env (collect_ev_bndrs new_binds)
+ ; binds' <- mapBagM (zonkEvBind env1) binds
+ ; return (env1, binds') })
+ where
+ collect_ev_bndrs :: Bag EvBind -> [EvVar]
+ collect_ev_bndrs = foldr add []
+ add (EvBind { eb_lhs = var }) vars = var : vars
+
+zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
+zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term })
+ = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var
+
+ -- Optimise the common case of Refl coercions
+ -- See Note [Optimise coercion zonking]
+ -- This has a very big effect on some programs (eg #5030)
+
+ ; term' <- case getEqPredTys_maybe (idType var') of
+ Just (r, ty1, ty2) | ty1 `eqType` ty2
+ -> return (evCoercion (mkTcReflCo r ty1))
+ _other -> zonkEvTerm env term
+
+ ; return (bind { eb_lhs = var', eb_rhs = term' }) }
+
+{- Note [Optimise coercion zonking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When optimising evidence binds we may come across situations where
+a coercion looks like
+ cv = ReflCo ty
+or cv1 = cv2
+where the type 'ty' is big. In such cases it is a waste of time to zonk both
+ * The variable on the LHS
+ * The coercion on the RHS
+Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just
+use Refl on the right, ignoring the actual coercion on the RHS.
+
+This can have a very big effect, because the constraint solver sometimes does go
+to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf #5030)
+
+
+************************************************************************
+* *
+ Zonking types
+* *
+************************************************************************
+-}
+
+{- Note [Sharing when zonking to Type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Problem:
+
+ In GHC.Tc.Utils.TcMType.zonkTcTyVar, we short-circuit (Indirect ty) to
+ (Indirect zty), see Note [Sharing in zonking] in GHC.Tc.Utils.TcMType. But we
+ /can't/ do this when zonking a TcType to a Type (#15552, esp
+ comment:3). Suppose we have
+
+ alpha -> alpha
+ where
+ alpha is already unified:
+ alpha := T{tc-tycon} Int -> Int
+ and T is knot-tied
+
+ By "knot-tied" I mean that the occurrence of T is currently a TcTyCon,
+ but the global env contains a mapping "T" :-> T{knot-tied-tc}. See
+ Note [Type checking recursive type and class declarations] in
+ GHC.Tc.TyCl.
+
+ Now we call zonkTcTypeToType on that (alpha -> alpha). If we follow
+ the same path as Note [Sharing in zonking] in GHC.Tc.Utils.TcMType, we'll
+ update alpha to
+ alpha := T{knot-tied-tc} Int -> Int
+
+ But alas, if we encounter alpha for a /second/ time, we end up
+ looking at T{knot-tied-tc} and fall into a black hole. The whole
+ point of zonkTcTypeToType is that it produces a type full of
+ knot-tied tycons, and you must not look at the result!!
+
+ To put it another way (zonkTcTypeToType . zonkTcTypeToType) is not
+ the same as zonkTcTypeToType. (If we distinguished TcType from
+ Type, this issue would have been a type error!)
+
+Solution: (see #15552 for other variants)
+
+ One possible solution is simply not to do the short-circuiting.
+ That has less sharing, but maybe sharing is rare. And indeed,
+ that turns out to be viable from a perf point of view
+
+ But the code implements something a bit better
+
+ * ZonkEnv contains ze_meta_tv_env, which maps
+ from a MetaTyVar (unification variable)
+ to a Type (not a TcType)
+
+ * In zonkTyVarOcc, we check this map to see if we have zonked
+ this variable before. If so, use the previous answer; if not
+ zonk it, and extend the map.
+
+ * The map is of course stateful, held in a TcRef. (That is unlike
+ the treatment of lexically-scoped variables in ze_tv_env and
+ ze_id_env.)
+
+ Is the extra work worth it? Some non-sytematic perf measurements
+ suggest that compiler allocation is reduced overall (by 0.5% or so)
+ but compile time really doesn't change.
+-}
+
+zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType
+zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi
+ , ze_tv_env = tv_env
+ , ze_meta_tv_env = mtv_env_ref }) tv
+ | isTcTyVar tv
+ = case tcTyVarDetails tv of
+ SkolemTv {} -> lookup_in_tv_env
+ RuntimeUnk {} -> lookup_in_tv_env
+ MetaTv { mtv_ref = ref }
+ -> do { mtv_env <- readTcRef mtv_env_ref
+ -- See Note [Sharing when zonking to Type]
+ ; case lookupVarEnv mtv_env tv of
+ Just ty -> return ty
+ Nothing -> do { mtv_details <- readTcRef ref
+ ; zonk_meta mtv_env ref mtv_details } }
+ | otherwise
+ = lookup_in_tv_env
+
+ where
+ lookup_in_tv_env -- Look up in the env just as we do for Ids
+ = case lookupVarEnv tv_env tv of
+ Nothing -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv
+ Just tv' -> return (mkTyVarTy tv')
+
+ zonk_meta mtv_env ref Flexi
+ = do { kind <- zonkTcTypeToTypeX env (tyVarKind tv)
+ ; ty <- commitFlexi flexi tv kind
+ ; writeMetaTyVarRef tv ref ty -- Belt and braces
+ ; finish_meta mtv_env ty }
+
+ zonk_meta mtv_env _ (Indirect ty)
+ = do { zty <- zonkTcTypeToTypeX env ty
+ ; finish_meta mtv_env zty }
+
+ finish_meta mtv_env ty
+ = do { let mtv_env' = extendVarEnv mtv_env tv ty
+ ; writeTcRef mtv_env_ref mtv_env'
+ ; return ty }
+
+lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar
+lookupTyVarOcc (ZonkEnv { ze_tv_env = tv_env }) tv
+ = lookupVarEnv tv_env tv
+
+commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type
+-- Only monadic so we can do tc-tracing
+commitFlexi flexi tv zonked_kind
+ = case flexi of
+ SkolemiseFlexi -> return (mkTyVarTy (mkTyVar name zonked_kind))
+
+ DefaultFlexi
+ | isRuntimeRepTy zonked_kind
+ -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv)
+ ; return liftedRepTy }
+ | otherwise
+ -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv)
+ ; return (anyTypeOfKind zonked_kind) }
+
+ RuntimeUnkFlexi
+ -> do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv)
+ ; return (mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk)) }
+ -- This is where RuntimeUnks are born:
+ -- otherwise-unconstrained unification variables are
+ -- turned into RuntimeUnks as they leave the
+ -- typechecker's monad
+ where
+ name = tyVarName tv
+
+zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion
+zonkCoVarOcc (ZonkEnv { ze_tv_env = tyco_env }) cv
+ | Just cv' <- lookupVarEnv tyco_env cv -- don't look in the knot-tied env
+ = return $ mkCoVarCo cv'
+ | otherwise
+ = do { cv' <- zonkCoVar cv; return (mkCoVarCo cv') }
+
+zonkCoHole :: ZonkEnv -> CoercionHole -> TcM Coercion
+zonkCoHole env hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })
+ = do { contents <- readTcRef ref
+ ; case contents of
+ Just co -> do { co' <- zonkCoToCo env co
+ ; checkCoercionHole cv co' }
+
+ -- This next case should happen only in the presence of
+ -- (undeferred) type errors. Originally, I put in a panic
+ -- here, but that caused too many uses of `failIfErrsM`.
+ Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole)
+ ; when debugIsOn $
+ whenNoErrs $
+ MASSERT2( False
+ , text "Type-correct unfilled coercion hole"
+ <+> ppr hole )
+ ; cv' <- zonkCoVar cv
+ ; return $ mkCoVarCo cv' } }
+ -- This will be an out-of-scope variable, but keeping
+ -- this as a coercion hole led to #15787
+
+zonk_tycomapper :: TyCoMapper ZonkEnv TcM
+zonk_tycomapper = TyCoMapper
+ { tcm_tyvar = zonkTyVarOcc
+ , tcm_covar = zonkCoVarOcc
+ , tcm_hole = zonkCoHole
+ , tcm_tycobinder = \env tv _vis -> zonkTyBndrX env tv
+ , tcm_tycon = zonkTcTyConToTyCon }
+
+-- Zonk a TyCon by changing a TcTyCon to a regular TyCon
+zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon
+zonkTcTyConToTyCon tc
+ | isTcTyCon tc = do { thing <- tcLookupGlobalOnly (getName tc)
+ ; case thing of
+ ATyCon real_tc -> return real_tc
+ _ -> pprPanic "zonkTcTyCon" (ppr tc $$ ppr thing) }
+ | otherwise = return tc -- it's already zonked
+
+-- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType.
+zonkTcTypeToType :: TcType -> TcM Type
+zonkTcTypeToType ty = initZonkEnv $ \ ze -> zonkTcTypeToTypeX ze ty
+
+zonkTcTypesToTypes :: [TcType] -> TcM [Type]
+zonkTcTypesToTypes tys = initZonkEnv $ \ ze -> zonkTcTypesToTypesX ze tys
+
+zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type
+zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type]
+zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion
+(zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkCoToCo, _)
+ = mapTyCoX zonk_tycomapper
+
+zonkTcMethInfoToMethInfoX :: ZonkEnv -> TcMethInfo -> TcM MethInfo
+zonkTcMethInfoToMethInfoX ze (name, ty, gdm_spec)
+ = do { ty' <- zonkTcTypeToTypeX ze ty
+ ; gdm_spec' <- zonk_gdm gdm_spec
+ ; return (name, ty', gdm_spec') }
+ where
+ zonk_gdm :: Maybe (DefMethSpec (SrcSpan, TcType))
+ -> TcM (Maybe (DefMethSpec (SrcSpan, Type)))
+ zonk_gdm Nothing = return Nothing
+ zonk_gdm (Just VanillaDM) = return (Just VanillaDM)
+ zonk_gdm (Just (GenericDM (loc, ty)))
+ = do { ty' <- zonkTcTypeToTypeX ze ty
+ ; return (Just (GenericDM (loc, ty'))) }
+
+---------------------------------------
+{- Note [Zonking the LHS of a RULE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also GHC.HsToCore.Binds Note [Free tyvars on rule LHS]
+
+We need to gather the type variables mentioned on the LHS so we can
+quantify over them. Example:
+ data T a = C
+
+ foo :: T a -> Int
+ foo C = 1
+
+ {-# RULES "myrule" foo C = 1 #-}
+
+After type checking the LHS becomes (foo alpha (C alpha)) and we do
+not want to zap the unbound meta-tyvar 'alpha' to Any, because that
+limits the applicability of the rule. Instead, we want to quantify
+over it!
+
+We do this in two stages.
+
+* During zonking, we skolemise the TcTyVar 'alpha' to TyVar 'a'. We
+ do this by using zonkTvSkolemising as the UnboundTyVarZonker in the
+ ZonkEnv. (This is in fact the whole reason that the ZonkEnv has a
+ UnboundTyVarZonker.)
+
+* In GHC.HsToCore.Binds, we quantify over it. See GHC.HsToCore.Binds
+ Note [Free tyvars on rule LHS]
+
+Quantifying here is awkward because (a) the data type is big and (b)
+finding the free type vars of an expression is necessarily monadic
+operation. (consider /\a -> f @ b, where b is side-effected to a)
+-}
View Lorry Controller Status