-addConstraint :: TcType -> TcType -> TR ()
-addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
-
-{-
- 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 = go True
- where
- go rewriteRHS lhs rhs
- -- TyVar lhs inductive case
- | Just tv <- getTyVar_maybe lhs
- = recoverM (return (lhs,rhs)) $ do
- Indirect ty_v <- readMetaTyVar tv
- (lhs', rhs') <- go rewriteRHS ty_v rhs
- writeMutVar (metaTvRef tv) (Indirect lhs')
- return (lhs, rhs')
- -- TyVar rhs inductive case
- | Just tv <- getTyVar_maybe rhs
- = recoverM (return (lhs,rhs)) $ do
- Indirect ty_v <- readMetaTyVar tv
- (lhs', rhs') <- go rewriteRHS lhs ty_v
- writeMutVar (metaTvRef tv) (Indirect rhs')
- return (lhs', rhs)
--- FunTy inductive case
- | Just (l1,l2) <- splitFunTy_maybe lhs
- , Just (r1,r2) <- splitFunTy_maybe rhs
- = do (l2',r2') <- go True l2 r2
- (l1',r1') <- go False 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 = do
-
- let (tycon_l',args_l') = if isNewTyCon tycon_r && not(isNewTyCon tycon_l)
- then (tycon_r, rewrite tycon_r lhs)
- else (tycon_l, args_l)
- (tycon_r',args_r') = if rewriteRHS && isNewTyCon tycon_l && not(isNewTyCon tycon_r)
- then (tycon_l, rewrite tycon_l rhs)
- else (tycon_r, args_r)
- (args_l'', args_r'') <- unzip `liftM` zipWithM (go rewriteRHS) args_l' args_r'
- return (mkTyConApp tycon_l' args_l'', mkTyConApp tycon_r' args_r'')
-
- | otherwise = return (lhs,rhs)
-
- 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
-