+ | 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
+{-
+ A parallel fold over two Type values,
+ compensating for missing newtypes on both sides.
+ This is necessary because newtypes are not present
+ in runtime, but since sometimes there is evidence
+ available we do our best to reconstruct them.
+ Evidence can come from DataCon signatures or
+ from compile-time type inference.
+ I am using the words congruence and rewriting
+ because what we are doing here is an approximation
+ of unification modulo a set of equations, which would
+ come from newtype definitions. These should be the
+ equality coercions seen in System Fc. Rewriting
+ is performed, taking those equations as rules,
+ before launching unification.
+
+ It doesn't make sense to rewrite everywhere,
+ or we would end up with all newtypes. So we rewrite
+ only in presence of evidence.
+ The lhs comes from the heap structure of ptrs,nptrs.
+ The rhs comes from a DataCon type signature.
+ Rewriting in the rhs is restricted to the result type.
+
+ Note that it is very tricky to make this 'rewriting'
+ work with the unification implemented by TcM, where
+ substitutions are 'inlined'. The order in which
+ constraints are unified is vital for this (or I am
+ using TcM wrongly).
+-}
+congruenceNewtypes :: TcType -> TcType -> TcM (TcType,TcType)
+congruenceNewtypes lhs rhs
+ -- TyVar lhs inductive case
+ | Just tv <- getTyVar_maybe lhs
+ = recoverM (return (lhs,rhs)) $ do
+ Indirect ty_v <- readMetaTyVar tv
+ (lhs1, rhs1) <- congruenceNewtypes ty_v rhs
+ return (lhs, rhs1)
+-- FunTy inductive case
+ | Just (l1,l2) <- splitFunTy_maybe lhs
+ , Just (r1,r2) <- splitFunTy_maybe rhs
+ = do (l2',r2') <- congruenceNewtypes l2 r2
+ (l1',r1') <- congruenceNewtypes l1 r1
+ return (mkFunTy l1' l2', mkFunTy r1' r2')
+-- TyconApp Inductive case; this is the interesting bit.
+ | Just (tycon_l, args_l) <- splitNewTyConApp_maybe lhs
+ , Just (tycon_r, args_r) <- splitNewTyConApp_maybe rhs
+ , tycon_l /= tycon_r
+ = return (lhs, upgrade tycon_l rhs)
+
+ | otherwise = return (lhs,rhs)
+
+ where upgrade :: TyCon -> Type -> Type
+ upgrade new_tycon ty
+ | not (isNewTyCon new_tycon) = ty
+ | ty' <- mkTyConApp new_tycon (map mkTyVarTy $ tyConTyVars new_tycon)
+ , Just subst <- tcUnifyTys (const BindMe) [ty] [repType ty']
+ = substTy subst ty'
+ -- assumes that reptype doesn't touch tyconApp args ^^^
+
+
+--------------------------------------------------------------------------------
+
+isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
+ = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
+
+mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
+mapMif pred f xx = sequence $ mapMif_ pred f xx
+mapMif_ pred f [] = []
+mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
+
+unlessM condM acc = condM >>= \c -> unless c acc
+
+-- Strict application of f at index i
+appArr f (Array _ _ ptrs#) (I# i#) = case indexArray# ptrs# i# of
+ (# e #) -> f e