tcSimplifyDeriv, tcSimplifyDefault,
bindInstsOfLocalFuns,
+
+ tcSimplifyStagedExpr,
misMatchMsg
) where
import SrcLoc
import DynFlags
import FastString
+
import Control.Monad
import Data.List
\end{code}
-- irreds2 will be empty. But we don't want to generalise over b!
; let preds2 = fdPredsOfInsts irreds2 -- irreds2 is zonked
qtvs = grow preds2 tau_tvs2 `minusVarSet` oclose preds2 gbl_tvs2
+ ---------------------------------------------------
+ -- BUG WARNING: there's a nasty bug lurking here
+ -- fdPredsOfInsts may return preds that mention variables quantified in
+ -- one of the implication constraints in irreds2; and that is clearly wrong:
+ -- we might quantify over too many variables through accidental capture
+ ---------------------------------------------------
+
; let (free, irreds3) = partition (isFreeWhenInferring qtvs) irreds2
; extendLIEs free
-- (ir1, .., irn) = f qtvs givens
-- where f is (evidence for) the new implication constraint
-- f :: forall qtvs. givens => (ir1, .., irn)
--- qtvs includes coercion variables.
+-- qtvs includes coercion variables
--
-- This binding must line up the 'rhs' in reduceImplication
makeImplicationBind loc all_tvs
name = mkInternalName uniq (mkVarOcc "ic") span
implic_inst = ImplicInst { tci_name = name,
tci_tyvars = all_tvs,
- tci_given = (eq_givens ++ dict_givens),
+ tci_given = eq_givens ++ dict_givens,
-- same order as binders
tci_wanted = irreds,
tci_loc = loc }
<.> mkWpTyApps eq_cotvs
<.> mkWpTyApps (mkTyVarTys all_tvs)
bind | [dict_irred_id] <- dict_irred_ids
- = VarBind dict_irred_id rhs
+ = mkVarBind dict_irred_id rhs
| otherwise
- = PatBind { pat_lhs = lpat
+ = L span $
+ PatBind { pat_lhs = lpat
, pat_rhs = unguardedGRHSs rhs
, pat_rhs_ty = hsLPatType lpat
, bind_fvs = placeHolderNames
}
; traceTc $ text "makeImplicationBind" <+> ppr implic_inst
- ; return ([implic_inst], unitBag (L span bind))
+ ; return ([implic_inst], unitBag bind)
}
-----------------------------------------------------------
eq_cotvs = map instToVar extra_eq_givens
dict_ids = map instToId extra_dict_givens
- -- Note [Always inline implication constraints]
- wrap_inline | null dict_ids = idHsWrapper
- | otherwise = WpInline
- co = wrap_inline
- <.> mkWpTyLams tvs
+ co = mkWpTyLams tvs
<.> mkWpTyLams eq_cotvs
<.> mkWpLams dict_ids
<.> WpLet (binds `unionBags` bind)
. filter (not . isEqInst)
$ wanteds
payload = mkBigLHsTup dict_bndrs
-
; traceTc (vcat [text "reduceImplication" <+> ppr name,
ppr simpler_implic_insts,
text "->" <+> ppr rhs])
- ; return (unitBag (L loc (VarBind (instToId orig_implic) rhs)),
+ ; return (unitBag (L loc (VarBind { var_id= instToId orig_implic
+ , var_rhs = rhs
+ , var_inline = not (null dict_ids) }
+ -- See Note [Always inline implication constraints]
+ )),
simpler_implic_insts)
}
}
doc = ptext (sLit "default declaration")
\end{code}
+@tcSimplifyStagedExpr@ performs a simplification but does so at a new
+stage. This is used when typechecking annotations and splices.
+
+\begin{code}
+
+tcSimplifyStagedExpr :: ThStage -> TcM a -> TcM (a, TcDictBinds)
+-- Type check an expression that runs at a top level stage as if
+-- it were going to be spliced and then simplify it
+tcSimplifyStagedExpr stage tc_action
+ = setStage stage $ do {
+ -- Typecheck the expression
+ (thing', lie) <- getLIE tc_action
+
+ -- Solve the constraints
+ ; const_binds <- tcSimplifyTop lie
+
+ ; return (thing', const_binds) }
+
+\end{code}
+
%************************************************************************
%* *