diff options
Diffstat (limited to 'compiler/GHC/Tc')
-rw-r--r-- | compiler/GHC/Tc/Errors/Types.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Head.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Tc/Solver/Monad.hs | 19 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/Concrete.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/TcMType.hs | 56 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/Zonk.hs | 2 |
6 files changed, 53 insertions, 31 deletions
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 6e58e6b033..a8d7c30846 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -3473,7 +3473,7 @@ data TcRnMessage where -> ![LIdP GhcRn] -- ^ The LHS args -> !PatSynInvalidRhsReason -- ^ The number of equation arguments -> TcRnMessage - {- TcRnCannotDefaultConcrete is an error occurring when a concrete + {-| TcRnCannotDefaultConcrete is an error occurring when a concrete type variable cannot be defaulted. Test cases: diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index d5721ff5e1..a5ad2f1733 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -883,7 +883,7 @@ tcExprWithSig expr hs_ty loc = getLocA (dropWildCards hs_ty) ctxt = ExprSigCtxt (lhsSigWcTypeContextSpan hs_ty) -tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType) +tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcSigmaType) tcExprSig ctxt expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) = setSrcSpan loc $ -- Sets the location for the implication constraint do { let poly_ty = idType poly_id diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index f3d0097f93..49699d865d 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -2119,14 +2119,17 @@ checkTouchableTyVarEq ev lhs_tv rhs ; if not (cterHasNoProblem reason) -- Failed to promote free vars then failCheckWith reason else - do { let tv_info | isConcreteInfo lhs_tv_info = lhs_tv_info - | otherwise = TauTv - -- Make a concrete tyvar if lhs_tv is concrete - -- e.g. alpha[2,conc] ~ Maybe (F beta[4]) - -- We want to flatten to - -- alpha[2,conc] ~ Maybe gamma[2,conc] - -- gamma[2,conc] ~ F beta[4] - ; new_tv_ty <- TcM.newMetaTyVarTyWithInfo lhs_tv_lvl tv_info fam_app_kind + do { new_tv_ty <- + case lhs_tv_info of + ConcreteTv conc_info -> + -- Make a concrete tyvar if lhs_tv is concrete + -- e.g. alpha[2,conc] ~ Maybe (F beta[4]) + -- We want to flatten to + -- alpha[2,conc] ~ Maybe gamma[2,conc] + -- gamma[2,conc] ~ F beta[4] + TcM.newConcreteTyVarTyAtLevel conc_info lhs_tv_lvl fam_app_kind + _ -> TcM.newMetaTyVarTyAtLevel lhs_tv_lvl fam_app_kind + ; let pty = mkPrimEqPredRole Nominal fam_app new_tv_ty ; hole <- TcM.newCoercionHole pty ; let new_ev = CtWanted { ctev_pred = pty diff --git a/compiler/GHC/Tc/Utils/Concrete.hs b/compiler/GHC/Tc/Utils/Concrete.hs index fe0f261005..a07401ec74 100644 --- a/compiler/GHC/Tc/Utils/Concrete.hs +++ b/compiler/GHC/Tc/Utils/Concrete.hs @@ -8,9 +8,6 @@ module GHC.Tc.Utils.Concrete ( -- * Ensuring that a type has a fixed runtime representation hasFixedRuntimeRep , hasFixedRuntimeRep_syntactic - - -- * Making a type concrete - , makeTypeConcrete ) where diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index b4971210fd..873ff2979a 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -24,7 +25,7 @@ module GHC.Tc.Utils.TcMType ( newOpenFlexiTyVar, newOpenFlexiTyVarTy, newOpenTypeKind, newOpenBoxedTypeKind, newMetaKindVar, newMetaKindVars, - newMetaTyVarTyAtLevel, newMetaTyVarTyWithInfo, + newMetaTyVarTyAtLevel, newConcreteTyVarTyAtLevel, newAnonMetaTyVar, newConcreteTyVar, cloneMetaTyVar, cloneMetaTyVarWithInfo, newCycleBreakerTyVar, @@ -482,7 +483,16 @@ newInferExpType :: TcM ExpType newInferExpType = new_inferExpType Nothing newInferExpTypeFRR :: FixedRuntimeRepContext -> TcM ExpTypeFRR -newInferExpTypeFRR frr_orig = new_inferExpType (Just frr_orig) +newInferExpTypeFRR frr_orig + = do { th_stage <- getStage + ; if + -- See [Wrinkle: Typed Template Haskell] + -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. + | Brack _ (TcPending {}) <- th_stage + -> new_inferExpType Nothing + + | otherwise + -> new_inferExpType (Just frr_orig) } new_inferExpType :: Maybe FixedRuntimeRepContext -> TcM ExpType new_inferExpType mb_frr_orig @@ -538,20 +548,28 @@ expTypeToType (Infer inf_res) = inferResultToType inf_res inferResultToType :: InferResult -> TcM Type inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl - , ir_ref = ref }) + , ir_ref = ref + , ir_frr = mb_frr }) = do { mb_inferred_ty <- readTcRef ref ; tau <- case mb_inferred_ty of Just ty -> do { ensureMonoType ty -- See Note [inferResultToType] ; return ty } - Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy - ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) - -- See Note [TcLevel of ExpType] + Nothing -> do { tau <- new_meta ; writeMutVar ref (Just tau) ; return tau } ; traceTc "Forcing ExpType to be monomorphic:" (ppr u <+> text ":=" <+> ppr tau) ; return tau } + where + -- See Note [TcLevel of ExpType] + new_meta = case mb_frr of + Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy + ; newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) } + Just frr -> mdo { rr <- newConcreteTyVarTyAtLevel conc_orig tc_lvl runtimeRepTy + ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) + ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr + ; return tau } {- Note [inferResultToType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -874,6 +892,13 @@ newTauTvDetailsAtLevel tclvl , mtv_ref = ref , mtv_tclvl = tclvl }) } +newConcreteTvDetailsAtLevel :: ConcreteTvOrigin -> TcLevel -> TcM TcTyVarDetails +newConcreteTvDetailsAtLevel conc_orig tclvl + = do { ref <- newMutVar Flexi + ; return (MetaTv { mtv_info = ConcreteTv conc_orig + , mtv_ref = ref + , mtv_tclvl = tclvl }) } + cloneMetaTyVar :: TcTyVar -> TcM TcTyVar cloneMetaTyVar tv = assert (isTcTyVar tv) $ @@ -931,7 +956,7 @@ isUnfilledMetaTyVar tv -------------------- -- Works with both type and kind variables -writeMetaTyVar :: TcTyVar -> TcType -> TcM () +writeMetaTyVar :: HasDebugCallStack => TcTyVar -> TcType -> TcM () -- Write into a currently-empty MetaTyVar writeMetaTyVar tyvar ty @@ -949,7 +974,7 @@ writeMetaTyVar tyvar ty = massertPpr False (text "Writing to non-meta tyvar" <+> ppr tyvar) -------------------- -writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM () +writeMetaTyVarRef :: HasDebugCallStack => 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 @@ -1114,13 +1139,10 @@ newMetaTyVarTyAtLevel tc_lvl kind ; name <- newMetaTyVarName (fsLit "p") ; return (mkTyVarTy (mkTcTyVar name kind details)) } -newMetaTyVarTyWithInfo :: TcLevel -> MetaInfo -> TcKind -> TcM TcType -newMetaTyVarTyWithInfo tc_lvl info kind - = do { ref <- newMutVar Flexi - ; let details = MetaTv { mtv_info = info - , mtv_ref = ref - , mtv_tclvl = tc_lvl } - ; name <- newMetaTyVarName (fsLit "p") +newConcreteTyVarTyAtLevel :: ConcreteTvOrigin -> TcLevel -> TcKind -> TcM TcType +newConcreteTyVarTyAtLevel conc_orig tc_lvl kind + = do { details <- newConcreteTvDetailsAtLevel conc_orig tc_lvl + ; name <- newMetaTyVarName (fsLit "c") ; return (mkTyVarTy (mkTcTyVar name kind details)) } {- ********************************************************************* @@ -2258,7 +2280,7 @@ a \/\a in the final result but all the occurrences of a will be zonked to () * * ********************************************************************* -} -promoteMetaTyVarTo :: TcLevel -> TcTyVar -> TcM Bool +promoteMetaTyVarTo :: HasDebugCallStack => TcLevel -> TcTyVar -> TcM Bool -- When we float a constraint out of an implication we must restore -- invariant (WantedInv) in Note [TcLevel invariants] in GHC.Tc.Utils.TcType -- Return True <=> we did some promotion @@ -2276,7 +2298,7 @@ promoteMetaTyVarTo tclvl tv = return False -- Returns whether or not *any* tyvar is defaulted -promoteTyVarSet :: TcTyVarSet -> TcM Bool +promoteTyVarSet :: HasDebugCallStack => TcTyVarSet -> TcM Bool promoteTyVarSet tvs = do { tclvl <- getTcLevel ; bools <- mapM (promoteMetaTyVarTo tclvl) $ diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 7a2c0de793..aa2ffa8bae 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -1738,7 +1738,7 @@ change. But in some cases it makes a HUGE difference: see test T9198 and #19668. So yes, it seems worth it. -} -zonkTyVarOcc :: ZonkEnv -> TcTyVar -> TcM Type +zonkTyVarOcc :: HasDebugCallStack => ZonkEnv -> TcTyVar -> TcM Type zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi , ze_tv_env = tv_env , ze_meta_tv_env = mtv_env_ref }) tv |