- where rewrite newtyped_tc lame_tipe
- | (tvs, tipe) <- newTyConRep newtyped_tc
- = case tcUnifyTys (const BindMe) [tipe] [lame_tipe] of
- Just subst -> substTys subst (map mkTyVarTy tvs)
- otherwise -> panic "congruenceNewtypes: Can't unify a newtype"
-
-newVar :: Kind -> TR TcTyVar
-newVar = liftTcM . newFlexiTyVar
-
-liftTcM = id
-
--- | Returns the instantiated type scheme ty', and the substitution sigma
--- such that sigma(ty') = ty
-instScheme :: Type -> TR (TcType, TvSubst)
-instScheme ty | (tvs, rho) <- tcSplitForAllTys ty = liftTcM$ do
- (tvs',theta,ty') <- tcInstType (mapM tcInstTyVar) ty
- return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
-
-cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
-cvObtainTerm hsc_env force mb_ty a = do
- -- Obtain the term and tidy the type before returning it
- term <- cvObtainTerm1 hsc_env force mb_ty a
- let term' = tidyTypes term
- return term'
- where allvars = nub . foldTerm TermFold {
- fTerm = \ty _ _ tt ->
- varEnvElts(tyVarsOfType ty) ++ concat tt,
- fSuspension = \_ mb_ty _ _ ->
- maybe [] (varEnvElts . tyVarsOfType) mb_ty,
- fPrim = \ _ _ -> [] }
- tidyTypes term = let
- go = foldTerm idTermFold {
- fTerm = \ty dc hval tt ->
- Term (tidy ty) dc hval tt,
- fSuspension = \ct mb_ty hval n ->
- Suspension ct (fmap tidy mb_ty) hval n }
- tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv) ty
- tidyVarEnv = mkVarEnv$
- [ (v, alpha_tv `setTyVarUnique` varUnique v)
- | (alpha_tv,v) <- zip alphaTyVars (allvars term)]
- in go term
-
-cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
-cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
- tv <- liftM mkTyVarTy (newVar argTypeKind)
- case mb_ty of
- Nothing -> go tv tv hval
- Just ty | isMonomorphic ty -> go ty ty hval
- Just ty -> do
- (ty',rev_subst) <- instScheme (sigmaType ty)
- addConstraint tv ty'
- term <- go tv tv hval
- --restore original Tyvars
- return$ flip foldTerm term idTermFold {
- fTerm = \ty dc hval tt -> Term (substTy rev_subst ty) dc hval tt,
- fSuspension = \ct mb_ty hval n ->
- Suspension ct (substTy rev_subst `fmap` mb_ty) hval n}
- 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
- 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
- instScheme(dataConRepType dc) >>= addConstraint myType . fst
- 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 (nonPtrs 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)
-
--- Access the array of pointers and recurse down. Needs to be done with
--- care of no introducing a thunk! or go will fail to do its job
- appArr f arr (I# i#) = case arr of
- (Array _ _ ptrs#) -> case indexArray# ptrs# i# of
- (# e #) -> f e
-
- matchSubTypes dc ty
- | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
- , null (dataConExTyVars dc) --TODO Handle the 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
-
-isMonomorphic ty | isForAllTy ty = False
-isMonomorphic ty = (isEmptyVarSet . tyVarsOfType) ty
+ 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'
+ upgrade _ _ = panic "congruenceNewtypes.upgrade"
+ -- assumes that reptype doesn't touch tyconApp args ^^^
+
+
+--------------------------------------------------------------------------------
+-- Semantically different to recoverM in TcRnMonad
+-- recoverM retains the errors in the first action,
+-- whereas recoverTc here does not
+recoverTc :: TcM a -> TcM a -> TcM a
+recoverTc recover thing = do
+ (_,mb_res) <- tryTcErrs thing
+ case mb_res of
+ Nothing -> recover
+ Just res -> return res
+
+isMonomorphic :: Type -> Bool
+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
+ where
+ mapMif_ _ _ [] = []
+ mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
+
+unlessM :: Monad m => m Bool -> m () -> m ()
+unlessM condM acc = condM >>= \c -> unless c acc
+
+-- Strict application of f at index i
+appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
+appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
+ = ASSERT (i < length(elems a))
+ case indexArray# ptrs# i# of
+ (# e #) -> f e