+ -- The interesting case
+ Constr -> do
+ traceTR (text "entering a constructor " <>
+ if monomorphic
+ then parens (text "already monomorphic: " <> ppr my_ty)
+ else Outputable.empty)
+ Right dcname <- dataConInfoPtrToName (infoPtr clos)
+ (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
+ case mb_dc of
+ Nothing -> do -- This can happen for private constructors compiled -O0
+ -- where the .hi descriptor does not export them
+ -- In such case, we return a best approximation:
+ -- ignore the unpointed args, and recover the pointeds
+ -- This preserves laziness, and should be safe.
+ let tag = showSDoc (ppr dcname)
+ vars <- replicateM (length$ elems$ ptrs clos)
+ (newVar (liftedTypeKind))
+ subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
+ | (i, tv) <- zip [0..] vars]
+ return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
+ Just dc -> do
+ let subTtypes = matchSubTypes dc old_ty
+ subTermTvs <- mapMif (not . isMonomorphic)
+ (\t -> newVar (typeKind t))
+ subTtypes
+ let (subTermsP, subTermsNP) = partition (\(ty,_) -> isLifted ty
+ || isRefType ty)
+ (zip subTtypes subTermTvs)
+ (subTtypesP, subTermTvsP ) = unzip subTermsP
+ (subTtypesNP, _subTermTvsNP) = unzip subTermsNP
+
+ -- When we already have all the information, avoid solving
+ -- unnecessary constraints. Propagation of type information
+ -- to subterms is already being done via matching.
+ when (not monomorphic) $ do
+ let myType = mkFunTys subTermTvs my_ty
+ (signatureType,_) <- instScheme (mydataConType dc)
+ -- It is vital for newtype reconstruction that the unification step
+ -- is done right here, _before_ the subterms are RTTI reconstructed
+ addConstraint myType signatureType
+ subTermsP <- sequence
+ [ appArr (go (pred max_depth) tv t) (ptrs clos) i
+ | (i,tv,t) <- zip3 [0..] subTermTvsP subTtypesP]
+ let unboxeds = extractUnboxed subTtypesNP clos
+ subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
+ subTerms = reOrderTerms subTermsP subTermsNP subTtypes
+ return (Term my_ty (Right dc) a subTerms)
+-- The otherwise case: can be a Thunk,AP,PAP,etc.
+ tipe_clos ->
+ return (Suspension tipe_clos my_ty a Nothing)
+
+ matchSubTypes dc ty
+ | ty' <- repType ty -- look through newtypes
+ , Just (tc,ty_args) <- tcSplitTyConApp_maybe ty'
+ , dc `elem` tyConDataCons tc
+ -- It is necessary to check that dc is actually a constructor for tycon tc,
+ -- because it may be the case that tc is a recursive newtype and tcSplitTyConApp
+ -- has not removed it. In that case, we happily give up and don't match
+ = myDataConInstArgTys dc ty_args
+ | otherwise = dataConRepArgTys dc
+
+ -- put together pointed and nonpointed subterms in the
+ -- correct order.
+ reOrderTerms _ _ [] = []
+ reOrderTerms pointed unpointed (ty:tys)
+ | isLifted ty || isRefType ty
+ = ASSERT2(not(null pointed)
+ , ptext (sLit "reOrderTerms") $$
+ (ppr pointed $$ ppr unpointed))
+ let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
+ | otherwise = ASSERT2(not(null unpointed)
+ , ptext (sLit "reOrderTerms") $$
+ (ppr pointed $$ ppr unpointed))
+ let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
+
+ -- insert NewtypeWraps around newtypes
+ expandNewtypes = foldTerm idTermFold { fTerm = worker } where
+ worker ty dc hval tt
+ | Just (tc, args) <- tcSplitTyConApp_maybe ty
+ , isNewTyCon tc
+ , wrapped_type <- newTyConInstRhs tc args
+ , Just dc' <- tyConSingleDataCon_maybe tc
+ , t' <- worker wrapped_type dc hval tt
+ = NewtypeWrap ty (Right dc') t'
+ | otherwise = Term ty dc hval tt
+
+
+ -- Avoid returning types where predicates have been expanded to dictionaries.
+ fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
+ worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
+ | otherwise = Suspension ct ty hval n
+
+
+-- Fast, breadth-first Type reconstruction
+------------------------------------------
+cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)
+cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
+ traceTR (text "RTTI started with initial type " <> ppr old_ty)
+ let sigma_old_ty@(old_tvs, _) = quantifyType old_ty
+ new_ty <-
+ if null old_tvs
+ then return old_ty
+ else do
+ (old_ty', rev_subst) <- instScheme sigma_old_ty
+ my_ty <- newVar argTypeKind
+ when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
+ addConstraint my_ty old_ty')
+ search (isMonomorphic `fmap` zonkTcType my_ty)
+ (\(ty,a) -> go ty a)
+ (Seq.singleton (my_ty, hval))
+ max_depth
+ new_ty <- zonkTcType my_ty
+ if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty
+ then do
+ traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty)
+ addConstraint my_ty old_ty'
+ applyRevSubst rev_subst
+ zonkRttiType new_ty
+ else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>
+ return old_ty
+ traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
+ return new_ty
+ where
+-- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
+ search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
+ int max_depth <> text " steps")
+ search stop expand l d =
+ case viewl l of
+ EmptyL -> return ()
+ x :< xx -> unlessM stop $ do
+ new <- expand x
+ search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
+
+ -- returns unification tasks,since we are going to want a breadth-first search
+ go :: Type -> HValue -> TR [(Type, HValue)]
+ go my_ty a = do
+ clos <- trIO $ getClosureData a
+ case tipe clos of
+ Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO
+ Indirection _ -> go my_ty $! (ptrs clos ! 0)
+ MutVar _ -> do
+ contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
+ tv' <- newVar liftedTypeKind
+ world <- newVar liftedTypeKind
+ addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
+ return [(tv', contents)]
+ Constr -> do
+ Right dcname <- dataConInfoPtrToName (infoPtr clos)
+ (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
+ case mb_dc of
+ Nothing-> do
+ -- TODO: Check this case
+ forM [0..length (elems $ ptrs clos)] $ \i -> do
+ tv <- newVar liftedTypeKind
+ return$ appArr (\e->(tv,e)) (ptrs clos) i
+
+ Just dc -> do
+ subTtypes <- mapMif (not . isMonomorphic)
+ (\t -> newVar (typeKind t))
+ (dataConRepArgTys dc)
+
+ -- It is vital for newtype reconstruction that the unification step
+ -- is done right here, _before_ the subterms are RTTI reconstructed
+ let myType = mkFunTys subTtypes my_ty
+ (signatureType,_) <- instScheme (mydataConType dc)
+ addConstraint myType signatureType
+ return $ [ appArr (\e->(t,e)) (ptrs clos) i
+ | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)]
+ _ -> return []
+
+-- Compute the difference between a base type and the type found by RTTI
+-- improveType <base_type> <rtti_type>
+-- The types can contain skolem type variables, which need to be treated as normal vars.
+-- In particular, we want them to unify with things.
+improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TvSubst
+improveRTTIType _ base_ty new_ty
+ = U.tcUnifyTys (const U.BindMe) [base_ty] [new_ty]
+
+myDataConInstArgTys :: DataCon -> [Type] -> [Type]
+myDataConInstArgTys dc args
+ | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args
+ | otherwise = dataConRepArgTys dc
+
+mydataConType :: DataCon -> QuantifiedType
+-- ^ Custom version of DataCon.dataConUserType where we
+-- - remove the equality constraints
+-- - use the representation types for arguments, including dictionaries
+-- - keep the original result type
+mydataConType dc
+ = ( (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
+ , mkFunTys arg_tys res_ty )
+ where univ_tvs = dataConUnivTyVars dc
+ ex_tvs = dataConExTyVars dc
+ eq_spec = dataConEqSpec dc
+ arg_tys = [case a of
+ PredTy p -> predTypeRep p
+ _ -> a
+ | a <- dataConRepArgTys dc]
+ res_ty = dataConOrigResTy dc
+
+isRefType :: Type -> Bool
+isRefType ty
+ | Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc
+ | otherwise = False
+ where ty'= repType ty
+
+isRefTyCon :: TyCon -> Bool
+isRefTyCon tc = tc `elem` [mutVarPrimTyCon, mVarPrimTyCon, tVarPrimTyCon]
+
+-- Soundness checks
+--------------------
+{-
+This is not formalized anywhere, so hold to your seats!
+RTTI in the presence of newtypes can be a tricky and unsound business.