tcSimplifyDeriv, tcSimplifyDefault,
bindInstsOfLocalFuns,
+
+ tcSimplifyStagedExpr,
misMatchMsg
) where
import SrcLoc
import DynFlags
import FastString
+
import Control.Monad
import Data.List
\end{code}
The excitement comes when simplifying the bindings for h. Initially
try to simplify {y @ [[t1]] t2, 0 @ t1}, with initial qtvs = {t2}.
-From this we get t1:=:t2, but also various bindings. We can't forget
+From this we get t1~t2, but also various bindings. We can't forget
the bindings (because of [LOOP]), but in fact t1 is what g is
polymorphic in.
-- (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 }
Conclusion: in the very special case of tcSimplifySuperClasses
we have one 'given' (namely the "this" dictionary) whose superclasses
-must not be added to 'givens' by addGiven. That is the *whole* reason
-for the red_given_scs field in RedEnv, and the function argument to
-addGiven.
+must not be added to 'givens' by addGiven.
+
+There is a complication though. Suppose there are equalities
+ instance (Eq a, a~b) => Num (a,b)
+Then we normalise the 'givens' wrt the equalities, so the original
+given "this" dictionary is cast to one of a different type. So it's a
+bit trickier than before to identify the "special" dictionary whose
+superclasses must not be added. See test
+ indexed-types/should_run/EqInInstance
+
+We need a persistent property of the dictionary to record this
+special-ness. Current I'm using the InstLocOrigin (a bit of a hack,
+but cool), which is maintained by dictionary normalisation.
+Specifically, the InstLocOrigin is
+ NoScOrigin
+then the no-superclass thing kicks in. WATCH OUT if you fiddle
+with InstLocOrigin!
\begin{code}
tcSimplifySuperClasses
-> TcM TcDictBinds
tcSimplifySuperClasses loc this givens sc_wanteds
= do { traceTc (text "tcSimplifySuperClasses")
+
+ -- Note [Recursive instances and superclases]
+ ; no_sc_loc <- getInstLoc NoScOrigin
+ ; let no_sc_this = setInstLoc this no_sc_loc
+
+ ; let env = RedEnv { red_doc = pprInstLoc loc,
+ red_try_me = try_me,
+ red_givens = no_sc_this : givens,
+ red_stack = (0,[]),
+ red_improve = False } -- No unification vars
+
+
; (irreds,binds1) <- checkLoop env sc_wanteds
; let (tidy_env, tidy_irreds) = tidyInsts irreds
- ; reportNoInstances tidy_env (Just (loc, givens)) tidy_irreds
+ ; reportNoInstances tidy_env (Just (loc, givens)) [] tidy_irreds
; return binds1 }
where
- env = RedEnv { red_doc = pprInstLoc loc,
- red_try_me = try_me,
- red_givens = this:givens,
- red_given_scs = add_scs,
- red_stack = (0,[]),
- red_improve = False } -- No unification vars
- add_scs g | g==this = NoSCs
- | otherwise = AddSCs
-
try_me _ = ReduceMe -- Try hard, so we completely solve the superclass
-- constraints right here. See Note [SUPERCLASS-LOOP 1]
\end{code}
-- Always dicts & equalities
-- but see Note [Rigidity]
- , red_given_scs :: Inst -> WantSCs -- See Note [Recursive instances and superclases]
-
, red_stack :: (Int, [Inst]) -- Recursion stack (for err msg)
-- See Note [RedStack]
}
mkRedEnv doc try_me givens
= RedEnv { red_doc = doc, red_try_me = try_me,
red_givens = givens,
- red_given_scs = const AddSCs,
red_stack = (0,[]),
red_improve = True }
mkInferRedEnv doc try_me
= RedEnv { red_doc = doc, red_try_me = try_me,
red_givens = [],
- red_given_scs = const AddSCs,
red_stack = (0,[]),
red_improve = True }
mkNoImproveRedEnv doc try_me
= RedEnv { red_doc = doc, red_try_me = try_me,
red_givens = [],
- red_given_scs = const AddSCs,
red_stack = (0,[]),
red_improve = True }
-- Build the Avail mapping from "given_dicts"
; (init_state, _) <- getLIE $ do
- { init_state <- foldlM (addGiven (red_given_scs env))
- emptyAvails givens'
+ { init_state <- foldlM addGiven emptyAvails givens'
; return init_state
}
where
avail = Rhs rhs_expr wanteds
-addGiven :: (Inst -> WantSCs) -> Avails -> Inst -> TcM Avails
-addGiven want_scs avails given = addAvailAndSCs (want_scs given) avails given (Given given)
- -- Conditionally add superclasses for 'givens'
+addGiven :: Avails -> Inst -> TcM Avails
+addGiven avails given
+ = addAvailAndSCs want_scs avails given (Given given)
+ where
+ want_scs = case instLocOrigin (instLoc given) of
+ NoScOrigin -> NoSCs
+ _other -> AddSCs
+ -- Conditionally add superclasses for 'given'
-- See Note [Recursive instances and superclases]
- --
- -- No ASSERT( not (given `elemAvails` avails) ) because in an instance
- -- decl for Ord t we can add both Ord t and Eq t as 'givens',
- -- so the assert isn't true
+
+ -- No ASSERT( not (given `elemAvails` avails) ) because in an
+ -- instance decl for Ord t we can add both Ord t and Eq t as
+ -- 'givens', so the assert isn't true
\end{code}
\begin{code}
; (irreds, _) <- tryHardCheckLoop doc wanteds
; let (tv_dicts, others) = partition ok irreds
- ; addNoInstanceErrs others
+ (tidy_env, tidy_insts) = tidyInsts others
+ ; reportNoInstances tidy_env Nothing [alt_fix] tidy_insts
-- See Note [Exotic derived instance contexts] in TcMType
; let rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars)
ok dict | isDict dict = validDerivPred (dictPred dict)
| otherwise = False
+ alt_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration instead,"),
+ ptext (sLit "so you can specify the instance context yourself")]
\end{code}
tcSimplifyDefault theta = do
wanteds <- newDictBndrsO DefaultOrigin theta
(irreds, _) <- tryHardCheckLoop doc wanteds
- addNoInstanceErrs irreds
+ addNoInstanceErrs irreds
if null irreds then
return ()
else
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}
+
%************************************************************************
%* *
-> TcM ()
addNoInstanceErrs insts
= do { let (tidy_env, tidy_insts) = tidyInsts insts
- ; reportNoInstances tidy_env Nothing tidy_insts }
+ ; reportNoInstances tidy_env Nothing [] tidy_insts }
reportNoInstances
:: TidyEnv
-- Nothing => top level
-- Just (d,g) => d describes the construct
-- with givens g
+ -> [SDoc] -- Alternative fix for no-such-instance
-> [Inst] -- What is wanted (can include implications)
-> TcM ()
-reportNoInstances tidy_env mb_what insts
- = groupErrs (report_no_instances tidy_env mb_what) insts
+reportNoInstances tidy_env mb_what alt_fix insts
+ = groupErrs (report_no_instances tidy_env mb_what alt_fix) insts
-report_no_instances :: TidyEnv -> Maybe (InstLoc, [Inst]) -> [Inst] -> TcM ()
-report_no_instances tidy_env mb_what insts
+report_no_instances :: TidyEnv -> Maybe (InstLoc, [Inst]) -> [SDoc] -> [Inst] -> TcM ()
+report_no_instances tidy_env mb_what alt_fixes insts
= do { inst_envs <- tcGetInstEnvs
; let (implics, insts1) = partition isImplicInst insts
(insts2, overlaps) = partitionWith (check_overlap inst_envs) insts1
complain_implic inst -- Recurse!
= reportNoInstances tidy_env
(Just (tci_loc inst, tci_given inst))
- (tci_wanted inst)
+ alt_fixes (tci_wanted inst)
check_overlap :: (InstEnv,InstEnv) -> Inst -> Either Inst SDoc
-- Right msg => overlap message
= vcat [ addInstLoc insts $
sep [ ptext (sLit "Could not deduce") <+> pprDictsTheta insts
, nest 2 $ ptext (sLit "from the context") <+> pprDictsTheta givens]
- , show_fixes (fix1 loc : fixes2) ]
+ , show_fixes (fix1 loc : fixes2 ++ alt_fixes) ]
| otherwise -- Top level
= vcat [ addInstLoc insts $
ptext (sLit "No instance") <> plural insts
<+> ptext (sLit "for") <+> pprDictsTheta insts
- , show_fixes fixes2 ]
+ , show_fixes (fixes2 ++ alt_fixes) ]
where
fix1 loc = sep [ ptext (sLit "add") <+> pprDictsTheta insts
projects / ghc-hetmet.git / blobdiff