loop n args_so_far res_ty
| isSigmaTy res_ty -- Do this before checking n==0, because we
- -- guarantee to return a BoxyRhoType, not a BoxySigmaType
+ -- guarantee to return a BoxyRhoType, not a
+ -- BoxySigmaType
= do { (gen_fn, (co_fn, res)) <- tcGen res_ty emptyVarSet $ \ _ res_ty' ->
loop n args_so_far res_ty'
; return (gen_fn <.> co_fn, res) }
; co_fn' <- wrapFunResCoercion [arg_ty] co_fn
; return (co_fn', res) }
+ -- Try to normalise synonym families and defer if that's not possible
+ loop n args_so_far ty@(TyConApp tc tys)
+ | isOpenSynTyCon tc
+ = do { (coi1, ty') <- tcNormaliseFamInst ty
+ ; case coi1 of
+ IdCo -> defer n args_so_far ty
+ -- no progress, but maybe solvable => defer
+ ACo _ -> -- progress: so lets try again
+ do { (co_fn, res) <- loop n args_so_far ty'
+ ; return $ (co_fn <.> coiToHsWrapper (mkSymCoI coi1), res)
+ }
+ }
+
-- res_ty might have a type variable at the head, such as (a b c),
-- in which case we must fill in with (->). Simplest thing to do
-- is to use boxyUnify, but we catch failure and generate our own
-- error message on failure
loop n args_so_far res_ty@(AppTy _ _)
= do { [arg_ty',res_ty'] <- newBoxyTyVarTys [argTypeKind, openTypeKind]
- ; (_, mb_coi) <- tryTcErrs $ boxyUnify res_ty (FunTy arg_ty' res_ty')
+ ; (_, mb_coi) <- tryTcErrs $
+ boxyUnify res_ty (FunTy arg_ty' res_ty')
; if isNothing mb_coi then bale_out args_so_far
- else do { case expectJust "subFunTys" mb_coi of
- IdCo -> return ()
- ACo co -> traceTc (text "you're dropping a coercion: " <+> ppr co)
- ; loop n args_so_far (FunTy arg_ty' res_ty')
+ else do { let coi = expectJust "subFunTys" mb_coi
+ ; (co_fn, res) <- loop n args_so_far (FunTy arg_ty'
+ res_ty')
+ ; return (co_fn <.> coiToHsWrapper coi, res)
}
}
- loop n args_so_far (TyVarTy tv)
+ loop n args_so_far ty@(TyVarTy tv)
| isTyConableTyVar tv
= do { cts <- readMetaTyVar tv
; case cts of
Indirect ty -> loop n args_so_far ty
- Flexi -> do { (res_ty:arg_tys) <- withMetaTvs tv kinds mk_res_ty
- ; res <- thing_inside (reverse args_so_far ++ arg_tys) res_ty
- ; return (idHsWrapper, res) } }
+ Flexi ->
+ do { (res_ty:arg_tys) <- withMetaTvs tv kinds mk_res_ty
+ ; res <- thing_inside (reverse args_so_far ++ arg_tys)
+ res_ty
+ ; return (idHsWrapper, res) } }
+ | otherwise -- defer as tyvar may be refined by equalities
+ = defer n args_so_far ty
where
mk_res_ty (res_ty' : arg_tys') = mkFunTys arg_tys' res_ty'
mk_res_ty [] = panic "TcUnify.mk_res_ty1"
loop n args_so_far res_ty = bale_out args_so_far
+ -- build a template type a1 -> ... -> an -> b and defer an equality
+ -- between that template and the expected result type res_ty; then,
+ -- use the template to type the thing_inside
+ defer n args_so_far ty
+ = do { arg_tys <- newFlexiTyVarTys n argTypeKind
+ ; res_ty' <- newFlexiTyVarTy openTypeKind
+ ; let fun_ty = mkFunTys arg_tys res_ty'
+ err = error_herald <> comma $$
+ text "which does not match its type"
+ ; coi <- addErrCtxt err $
+ defer_unification False False fun_ty ty
+ ; res <- thing_inside (reverse args_so_far ++ arg_tys) res_ty'
+ ; return (coiToHsWrapper coi, res)
+ }
+
bale_out args_so_far
= do { env0 <- tcInitTidyEnv
; res_ty' <- zonkTcType res_ty
| isOpenSynTyCon tycon -- try to normalise type family application
= do { (coi1, ty') <- tcNormaliseFamInst ty
+ ; traceTc $ text "boxySplitTyConApp:" <+>
+ ppr ty <+> text "==>" <+> ppr ty'
; case coi1 of
IdCo -> defer -- no progress, but maybe solvable => defer
ACo _ -> -- progress: so lets try again
; traceTc (case coi of
IdCo -> text "tc_sub1 (Rule SBOXY) IdCo"
ACo co -> text "tc_sub1 (Rule SBOXY) ACo" <+> ppr co)
- ; return $ case coi of
- IdCo -> idHsWrapper
- ACo co -> WpCo co
+ ; return $ coiToHsWrapper coi
}
-----------------------------------
defer_to_boxy_matching sub_ctxt act_sty actual_ty exp_ib exp_sty expected_ty
= do { coi <- addSubCtxt sub_ctxt act_sty exp_sty $
u_tys outer False act_sty actual_ty exp_ib exp_sty expected_ty
- ; return $ case coi of
- IdCo -> idHsWrapper
- ACo co -> WpCo co
+ ; return $ coiToHsWrapper coi
}
where
outer = case sub_ctxt of -- Ugh
-----------------------
unifyMisMatch outer swapped ty1 ty2
- = do { (env, msg) <- if swapped then misMatchMsg ty2 ty1
- else misMatchMsg ty1 ty2
-
- -- This is the whole point of the 'outer' stuff
- ; if outer then popErrCtxt (failWithTcM (env, msg))
- else failWithTcM (env, msg)
- }
+ | swapped = unifyMisMatch outer False ty2 ty1
+ | outer = popErrCtxt $ unifyMisMatch False swapped ty1 ty2 -- This is the whole point of the 'outer' stuff
+ | otherwise = failWithMisMatch ty1 ty2
\end{code}