+
+
+-- Type & Term reconstruction
+cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
+cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
+ tv <- liftM mkTyVarTy (newVar argTypeKind)
+ case mb_ty of
+ Nothing -> go tv tv hval >>= zonkTerm
+ Just ty | isMonomorphic ty -> go ty ty hval >>= zonkTerm
+ Just ty -> do
+ (ty',rev_subst) <- instScheme (sigmaType ty)
+ addConstraint tv ty'
+ term <- go tv tv hval >>= zonkTerm
+ --restore original Tyvars
+ return$ mapTermType (substTy rev_subst) term
+ where
+ go tv ty a = do
+ let monomorphic = not(isTyVarTy tv)
+ -- This ^^^ is a convention. The ancestor tests for
+ -- monomorphism and passes a type instead of a tv
+ clos <- trIO $ getClosureData a
+ case tipe clos of
+-- Thunks we may want to force
+-- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
+-- force blackholes, because it would almost certainly result in deadlock,
+-- and showing the '_' is more useful.
+ t | isThunk t && force -> seq a $ go tv ty a
+-- We always follow indirections
+ Indirection _ -> go tv ty $! (ptrs clos ! 0)
+ -- The interesting case
+ Constr -> do
+ m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
+ case m_dc of
+ Nothing -> panic "Can't find the DataCon for a term"
+ Just dc -> do
+ let extra_args = length(dataConRepArgTys dc) -
+ length(dataConOrigArgTys dc)
+ subTtypes = matchSubTypes dc ty
+ (subTtypesP, subTtypesNP) = partition isPointed subTtypes
+ subTermTvs <- sequence
+ [ if isMonomorphic t then return t
+ else (mkTyVarTy `fmap` newVar k)
+ | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
+ -- It is vital for newtype reconstruction that the unification step
+ -- is done right here, _before_ the subterms are RTTI reconstructed
+ when (not monomorphic) $ do
+ let myType = mkFunTys (reOrderTerms subTermTvs
+ subTtypesNP
+ subTtypes)
+ tv
+ (signatureType,_) <- instScheme(dataConRepType dc)
+ addConstraint myType signatureType
+ subTermsP <- sequence $ drop extra_args
+ -- ^^^ all extra arguments are pointed
+ [ appArr (go tv t) (ptrs clos) i
+ | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
+ let unboxeds = extractUnboxed subTtypesNP clos
+ subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
+ subTerms = reOrderTerms subTermsP subTermsNP
+ (drop extra_args subTtypes)
+ return (Term tv dc a subTerms)
+-- The otherwise case: can be a Thunk,AP,PAP,etc.
+ otherwise ->
+ return (Suspension (tipe clos) (Just tv) a Nothing)
+
+ matchSubTypes dc ty
+ | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
+ , null (dataConExTyVars dc) --TODO case of extra existential tyvars
+ = dataConInstArgTys dc ty_args
+
+ | otherwise = dataConRepArgTys dc
+
+-- This is used to put together pointed and nonpointed subterms in the
+-- correct order.
+ reOrderTerms _ _ [] = []
+ reOrderTerms pointed unpointed (ty:tys)
+ | isPointed ty = ASSERT2(not(null pointed)
+ , ptext SLIT("reOrderTerms") $$
+ (ppr pointed $$ ppr unpointed))
+ head pointed : reOrderTerms (tail pointed) unpointed tys
+ | otherwise = ASSERT2(not(null unpointed)
+ , ptext SLIT("reOrderTerms") $$
+ (ppr pointed $$ ppr unpointed))
+ head unpointed : reOrderTerms pointed (tail unpointed) tys
+
+
+
+-- Fast, breadth-first Type reconstruction
+
+cvReconstructType :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Type
+cvReconstructType hsc_env force mb_ty hval = runTR hsc_env $ do
+ tv <- liftM mkTyVarTy (newVar argTypeKind)
+ case mb_ty of
+ Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
+ (uncurry go)
+ [(tv, hval)]
+ zonkTcType tv -- TODO untested!
+ Just ty | isMonomorphic ty -> return ty
+ Just ty -> do
+ (ty',rev_subst) <- instScheme (sigmaType ty)
+ addConstraint tv ty'
+ search (isMonomorphic `fmap` zonkTcType tv)
+ (uncurry go)
+ [(tv, hval)]
+ substTy rev_subst `fmap` zonkTcType tv
+ where
+-- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
+ search stop expand [] = return ()
+ search stop expand (x:xx) = do new <- expand x
+ unlessM stop $ search stop expand (xx ++ new)
+
+ -- returns unification tasks,since we are going to want a breadth-first search
+ go :: Type -> HValue -> TR [(Type, HValue)]
+ go tv a = do
+ clos <- trIO $ getClosureData a
+ case tipe clos of
+ Indirection _ -> go tv $! (ptrs clos ! 0)
+ Constr -> do
+ m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
+ case m_dc of
+ Nothing -> panic "Can't find the DataCon for a term"
+ Just dc -> do
+ let extra_args = length(dataConRepArgTys dc) -
+ length(dataConOrigArgTys dc)
+ subTtypes <- mapMif (not . isMonomorphic)
+ (\t -> mkTyVarTy `fmap` 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 tv
+ (signatureType,_) <- instScheme(dataConRepType dc)
+ addConstraint myType signatureType
+ return $ map (\(I# i#,t) -> case ptrs clos of
+ (Array _ _ ptrs#) -> case indexArray# ptrs# i# of
+ (# e #) -> (t,e))
+ (drop extra_args $ zip [0..] subTtypes)
+ otherwise -> return []
+
+
+-- Dealing with newtypes