diff options
| -rw-r--r-- | compiler/deSugar/DsBinds.hs | 122 | ||||
| -rw-r--r-- | compiler/typecheck/TcEvTerm.hs | 121 | ||||
| -rw-r--r-- | compiler/typecheck/TcInteract.hs | 25 |
3 files changed, 131 insertions, 137 deletions
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 5974a60117..75675a6e77 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -1186,126 +1186,4 @@ dsEvDelayedError ty msg where errorId = tYPE_ERROR_ID litMsg = Lit (MachStr (fastStringToByteString msg)) - -{-********************************************************************** -* * - Desugaring Typeable dictionaries -* * -**********************************************************************-} - -dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr --- Return a CoreExpr :: Typeable ty --- This code is tightly coupled to the representation --- of TypeRep, in base library Data.Typeable.Internals -dsEvTypeable ty ev - = do { tyCl <- dsLookupTyCon typeableClassName -- Typeable - ; let kind = typeKind ty - Just typeable_data_con - = tyConSingleDataCon_maybe tyCl -- "Data constructor" - -- for Typeable - - ; rep_expr <- ds_ev_typeable ty ev -- :: TypeRep a - - -- Package up the method as `Typeable` dictionary - ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] } - -type TypeRepExpr = CoreExpr - --- | Returns a @CoreExpr :: TypeRep ty@ -ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr -ds_ev_typeable ty (EvTypeableTyCon tc kind_ev) - = do { mkTrCon <- dsLookupGlobalId mkTrConName - -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a - ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName - ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName - -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep - - ; tc_rep <- tyConRep tc -- :: TyCon - ; let ks = tyConAppArgs ty - -- Construct a SomeTypeRep - toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr - toSomeTypeRep t ev = do - rep <- getRep ev t - return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep] - ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev -- :: TypeRep t - ; let -- :: [SomeTypeRep] - kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps - - -- Note that we use the kind of the type, not the TyCon from which it - -- is constructed since the latter may be kind polymorphic whereas the - -- former we know is not (we checked in the solver). - ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty) - , Type ty - , tc_rep - , kind_args ] - -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr - ; return expr - } - -ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) - | Just (t1,t2) <- splitAppTy_maybe ty - = do { e1 <- getRep ev1 t1 - ; e2 <- getRep ev2 t2 - ; mkTrApp <- dsLookupGlobalId mkTrAppName - -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). - -- TypeRep a -> TypeRep b -> TypeRep (a b) - ; let (k1, k2) = splitFunTy (typeKind t1) - ; let expr = mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ]) - [ e1, e2 ] - -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr - ; return expr - } - -ds_ev_typeable ty (EvTypeableTrFun ev1 ev2) - | Just (t1,t2) <- splitFunTy_maybe ty - = do { e1 <- getRep ev1 t1 - ; e2 <- getRep ev2 t2 - ; mkTrFun <- dsLookupGlobalId mkTrFunName - -- mkTrFun :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). - -- TypeRep a -> TypeRep b -> TypeRep (a -> b) - ; let r1 = getRuntimeRep t1 - r2 = getRuntimeRep t2 - ; return $ mkApps (mkTyApps (Var mkTrFun) [r1, r2, t1, t2]) - [ e1, e2 ] - } - -ds_ev_typeable ty (EvTypeableTyLit ev) - = do { fun <- dsLookupGlobalId tr_fun - ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSym - ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty] - ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) } - where - ty_kind = typeKind ty - - -- tr_fun is the Name of - -- typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep a - -- of typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a - tr_fun | ty_kind `eqType` typeNatKind = typeNatTypeRepName - | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName - | otherwise = panic "dsEvTypeable: unknown type lit kind" - -ds_ev_typeable ty ev - = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev) - -getRep :: EvTerm -- ^ EvTerm for @Typeable ty@ - -> Type -- ^ The type @ty@ - -> DsM TypeRepExpr -- ^ Return @CoreExpr :: TypeRep ty@ - -- namely @typeRep# dict@ --- Remember that --- typeRep# :: forall k (a::k). Typeable k a -> TypeRep a -getRep ev ty - = do { typeable_expr <- dsEvTerm ev - ; typeRepId <- dsLookupGlobalId typeRepIdName - ; let ty_args = [typeKind ty, ty] - ; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ typeable_expr ]) } - -tyConRep :: TyCon -> DsM CoreExpr --- Returns CoreExpr :: TyCon -tyConRep tc - | Just tc_rep_nm <- tyConRepName_maybe tc - = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm - ; return (Var tc_rep_id) } - | otherwise - = pprPanic "tyConRep" (ppr tc) -} - diff --git a/compiler/typecheck/TcEvTerm.hs b/compiler/typecheck/TcEvTerm.hs index 7e148f6e03..21cce3bb5f 100644 --- a/compiler/typecheck/TcEvTerm.hs +++ b/compiler/typecheck/TcEvTerm.hs @@ -20,6 +20,11 @@ import Module import CoreUtils import PrelNames import SrcLoc +import TyCon +import Outputable +import MkId +import TysWiredIn +import Control.Monad (zipWithM) -- Used with Opt_DeferTypeErrors -- See Note [Deferring coercion errors to runtime] @@ -69,6 +74,116 @@ evCallStack cs = do EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm EvCsEmpty -> return emptyCS --- Dictionary for (Typeable ty) -evTypeable :: Type -> EvTypeable -> EvTerm -evTypeable = undefined +evTypeable :: MonadThings m => Type -> EvTypeable -> m CoreExpr +-- Return a CoreExpr :: Typeable ty +-- This code is tightly coupled to the representation +-- of TypeRep, in base library Data.Typeable.Internals +evTypeable ty ev + = do { tyCl <- lookupTyCon typeableClassName -- Typeable + ; let kind = typeKind ty + Just typeable_data_con + = tyConSingleDataCon_maybe tyCl -- "Data constructor" + -- for Typeable + + ; rep_expr <- ds_ev_typeable ty ev -- :: TypeRep a + + -- Package up the method as `Typeable` dictionary + ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] } + +type TypeRepExpr = CoreExpr + +-- | Returns a @CoreExpr :: TypeRep ty@ +ds_ev_typeable :: MonadThings m => Type -> EvTypeable -> m CoreExpr +ds_ev_typeable ty (EvTypeableTyCon tc kind_ev) + = do { mkTrCon <- lookupId mkTrConName + -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a + ; someTypeRepTyCon <- lookupTyCon someTypeRepTyConName + ; someTypeRepDataCon <- lookupDataCon someTypeRepDataConName + -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep + + ; tc_rep <- tyConRep tc -- :: TyCon + ; let ks = tyConAppArgs ty + -- Construct a SomeTypeRep + toSomeTypeRep :: MonadThings m => Type -> EvTerm -> m CoreExpr + toSomeTypeRep t ev = do + rep <- getRep ev t + return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep] + ; kind_arg_reps <- zipWithM toSomeTypeRep ks kind_ev -- :: TypeRep t + ; let -- :: [SomeTypeRep] + kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps + + -- Note that we use the kind of the type, not the TyCon from which it + -- is constructed since the latter may be kind polymorphic whereas the + -- former we know is not (we checked in the solver). + ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty) + , Type ty + , tc_rep + , kind_args ] + -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr + ; return expr + } + +ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) + | Just (t1,t2) <- splitAppTy_maybe ty + = do { e1 <- getRep ev1 t1 + ; e2 <- getRep ev2 t2 + ; mkTrApp <- lookupId mkTrAppName + -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). + -- TypeRep a -> TypeRep b -> TypeRep (a b) + ; let (k1, k2) = splitFunTy (typeKind t1) + ; let expr = mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ]) + [ e1, e2 ] + -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr + ; return expr + } + +ds_ev_typeable ty (EvTypeableTrFun ev1 ev2) + | Just (t1,t2) <- splitFunTy_maybe ty + = do { e1 <- getRep ev1 t1 + ; e2 <- getRep ev2 t2 + ; mkTrFun <- lookupId mkTrFunName + -- mkTrFun :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). + -- TypeRep a -> TypeRep b -> TypeRep (a -> b) + ; let r1 = getRuntimeRep t1 + r2 = getRuntimeRep t2 + ; return $ mkApps (mkTyApps (Var mkTrFun) [r1, r2, t1, t2]) + [ e1, e2 ] + } + +ds_ev_typeable ty (EvTypeableTyLit dict) + = do { fun <- lookupId tr_fun + ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty] + ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) } + where + ty_kind = typeKind ty + + -- tr_fun is the Name of + -- typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep a + -- of typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a + tr_fun | ty_kind `eqType` typeNatKind = typeNatTypeRepName + | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName + | otherwise = panic "dsEvTypeable: unknown type lit kind" + +ds_ev_typeable ty ev + = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev) + +getRep :: MonadThings m + => EvTerm -- ^ EvTerm for @Typeable ty@ + -> Type -- ^ The type @ty@ + -> m TypeRepExpr -- ^ Return @CoreExpr :: TypeRep ty@ + -- namely @typeRep# dict@ +-- Remember that +-- typeRep# :: forall k (a::k). Typeable k a -> TypeRep a +getRep ev ty + = do { typeRepId <- lookupId typeRepIdName + ; let ty_args = [typeKind ty, ty] + ; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ ev ]) } + +tyConRep :: MonadThings m => TyCon -> m CoreExpr +-- Returns CoreExpr :: TyCon +tyConRep tc + | Just tc_rep_nm <- tyConRepName_maybe tc + = do { tc_rep_id <- lookupId tc_rep_nm + ; return (Var tc_rep_id) } + | otherwise + = pprPanic "tyConRep" (ppr tc) diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index e40d71f668..b3e4f9c2f3 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -1094,8 +1094,9 @@ shortCutSolver dflags ev_w ev_i -- so we can solve recursive dictionaries. ; subgoalBinds <- mapM (try_solve_from_instance loc' cache') (freshGoals evc_vs) - ; return $ (mk_ev (map getEvTerm evc_vs), ev, cls, preds) - : concat subgoalBinds } + ; ev_expr <- lift $ mk_ev (map getEvTerm evc_vs) + ; return $ (ev_expr, ev, cls, preds) : concat subgoalBinds + } | otherwise -> mzero _ -> mzero } @@ -2236,12 +2237,13 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls = loc finish_wanted :: [TcPredType] - -> ([EvTerm] -> EvTerm) -> TcS (StopOrContinue Ct) + -> ([EvTerm] -> TcS EvTerm) -> TcS (StopOrContinue Ct) -- Precondition: evidence term matches the predicate workItem finish_wanted theta mk_ev = do { addSolvedDict fl cls xis ; evc_vars <- mapM (newWanted deeper_loc) theta - ; setWantedEvBind (ctEvEvId fl) (mk_ev (map getEvTerm evc_vars)) + ; ev_expr <- mk_ev (map getEvTerm evc_vars) + ; setWantedEvBind (ctEvEvId fl) ev_expr ; emitWorkNC (freshGoals evc_vars) ; stopWith fl "Dict/Top (solved wanted)" } @@ -2288,7 +2290,7 @@ type SafeOverlapping = Bool data LookupInstResult = NoInstance | GenInst { lir_new_theta :: [TcPredType] - , lir_mk_ev :: [EvTerm] -> EvTerm + , lir_mk_ev :: [EvTerm] -> TcS EvTerm , lir_safe_over :: SafeOverlapping } instance Outputable LookupInstResult where @@ -2532,7 +2534,7 @@ matchInstEnv dflags short_cut_solver clas tys loc = do { checkWellStagedDFun pred dfun_id loc ; (tys, theta) <- instDFunType dfun_id mb_inst_tys ; return $ GenInst { lir_new_theta = theta - , lir_mk_ev = evDFunApp dfun_id tys + , lir_mk_ev = return . evDFunApp dfun_id tys , lir_safe_over = so } } @@ -2545,7 +2547,7 @@ matchInstEnv dflags short_cut_solver clas tys loc matchCTuple :: Class -> [Type] -> TcS LookupInstResult matchCTuple clas tys -- (isCTupleClass clas) holds = return (GenInst { lir_new_theta = tys - , lir_mk_ev = tuple_ev + , lir_mk_ev = return . tuple_ev , lir_safe_over = True }) -- The dfun *is* the data constructor! where @@ -2644,7 +2646,7 @@ makeLitDict clas ty et -- SNat n ~ Integer , let ev_tm = mkEvCast et (mkTcSymCo (mkTcTransCo co_dict co_rep)) = return $ GenInst { lir_new_theta = [] - , lir_mk_ev = \_ -> ev_tm + , lir_mk_ev = \_ -> return ev_tm , lir_safe_over = True } | otherwise @@ -2785,15 +2787,14 @@ a TypeRep for them. For qualified but not polymorphic types, like matchLiftedEquality :: [Type] -> TcS LookupInstResult matchLiftedEquality args = return (GenInst { lir_new_theta = [ mkTyConApp eqPrimTyCon args ] - , lir_mk_ev = evDFunApp (dataConWrapId heqDataCon) args + , lir_mk_ev = return . evDFunApp (dataConWrapId heqDataCon) args , lir_safe_over = True }) -- See also Note [The equality types story] in TysPrim matchLiftedCoercible :: [Type] -> TcS LookupInstResult matchLiftedCoercible args@[k, t1, t2] = return (GenInst { lir_new_theta = [ mkTyConApp eqReprPrimTyCon args' ] - , lir_mk_ev = evDFunApp (dataConWrapId coercibleDataCon) - args + , lir_mk_ev = return . evDFunApp (dataConWrapId coercibleDataCon) args , lir_safe_over = True }) where args' = [k, k, t1, t2] @@ -2894,7 +2895,7 @@ matchHasField dflags short_cut clas tys loc -- Use the equality proof to cast the selector Id to -- type (r -> a), then use the newtype coercion to cast -- it to a HasField dictionary. - mk_ev (ev1:evs) = evSelector sel_id tvs evs `evCast` co + mk_ev (ev1:evs) = return $ evSelector sel_id tvs evs `evCast` co where co = mkTcSubCo (evTermCoercion ev1) `mkTcTransCo` mkTcSymCo co2 |