#include "HsVersions.h"
import {-# SOURCE #-} TcUnify( unifyType )
-import TypeRep ( Type(..) )
-import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds )
-import TcHsSyn ( mkHsApp, mkHsTyApp, mkHsDictApp )
+import HsSyn ( HsBind(..), HsExpr(..), LHsExpr,
+ ExprCoFn(..), (<.>), nlHsTyApp, emptyLHsBinds )
+import TcHsSyn ( mkHsApp )
import TcRnMonad
import Inst ( lookupInst, LookupInstResult(..),
isMethodFor, isMethod,
instToId, tyVarsOfInsts, cloneDict,
ipNamesOfInsts, ipNamesOfInst, dictPred,
- fdPredsOfInst,
+ fdPredsOfInst, mkInstCoFn,
newDictsAtLoc, tcInstClassOp,
getDictClassTys, isTyVarDict, instLoc,
zonkInst, tidyInsts, tidyMoreInsts,
import Util ( zipEqual, isSingleton )
import List ( partition )
import SrcLoc ( Located(..) )
-import DynFlags ( DynFlag(..) )
-import StaticFlags
+import DynFlags ( DynFlags(ctxtStkDepth),
+ DynFlag( Opt_GlasgowExts, Opt_AllowUndecidableInstances,
+ Opt_WarnTypeDefaults, Opt_ExtendedDefaultRules ) )
\end{code}
Notes on functional dependencies (a bug)
--------------------------------------
+Consider this:
+
+ class C a b | a -> b
+ class D a b | a -> b
+
+ instance D a b => C a b -- Undecidable
+ -- (Not sure if it's crucial to this eg)
+ f :: C a b => a -> Bool
+ f _ = True
+
+ g :: C a b => a -> Bool
+ g = f
+
+Here f typechecks, but g does not!! Reason: before doing improvement,
+we reduce the (C a b1) constraint from the call of f to (D a b1).
+
+Here is a more complicated example:
+
| > class Foo a b | a->b
| >
| > class Bar a b | a->b
- --------------------------------------
- Notes on ambiguity
- --------------------------------------
+-------------------------------------
+ Note [Ambiguity]
+-------------------------------------
It's very hard to be certain when a type is ambiguous. Consider
tcSimplifySuperClasses qtvs givens sc_wanteds
= ASSERT( all isSkolemTyVar qtvs )
do { (_, frees, binds1) <- tcSimplCheck doc get_qtvs NoSCs givens sc_wanteds
- ; binds2 <- tc_simplify_top doc False NoSCs frees
+ ; ext_default <- doptM Opt_ExtendedDefaultRules
+ ; binds2 <- tc_simplify_top doc ext_default NoSCs frees
; return (binds1 `unionBags` binds2) }
where
get_qtvs = return (mkVarSet qtvs)
tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
-- Zonk everything in sight
= mappM zonkInst wanteds `thenM` \ wanteds' ->
- zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' ->
- tcGetGlobalTyVars `thenM` \ gbl_tvs' ->
-- 'reduceMe': Reduce as far as we can. Don't stop at
-- dicts; the idea is to get rid of as many type
-- immediately, with no constraint on s.
--
-- BUT do no improvement! See Plan D above
+ -- HOWEVER, some unification may take place, if we instantiate
+ -- a method Inst with an equality constraint
reduceContextWithoutImprovement
doc reduceMe wanteds' `thenM` \ (_frees, _binds, constrained_dicts) ->
-- Next, figure out the tyvars we will quantify over
+ zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' ->
+ tcGetGlobalTyVars `thenM` \ gbl_tvs' ->
+ mappM zonkInst constrained_dicts `thenM` \ constrained_dicts' ->
let
- constrained_tvs = tyVarsOfInsts constrained_dicts
- qtvs = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs')
- `minusVarSet` constrained_tvs
+ constrained_tvs' = tyVarsOfInsts constrained_dicts'
+ qtvs' = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs')
+ `minusVarSet` constrained_tvs'
in
traceTc (text "tcSimplifyRestricted" <+> vcat [
- pprInsts wanteds, pprInsts _frees, pprInsts constrained_dicts,
+ pprInsts wanteds, pprInsts _frees, pprInsts constrained_dicts',
ppr _binds,
- ppr constrained_tvs, ppr tau_tvs', ppr qtvs ]) `thenM_`
+ ppr constrained_tvs', ppr tau_tvs', ppr qtvs' ]) `thenM_`
-- The first step may have squashed more methods than
-- necessary, so try again, this time more gently, knowing the exact
-- set of type variables to quantify over.
--
- -- We quantify only over constraints that are captured by qtvs;
+ -- We quantify only over constraints that are captured by qtvs';
-- these will just be a subset of non-dicts. This in contrast
-- to normal inference (using isFreeWhenInferring) in which we quantify over
-- all *non-inheritable* constraints too. This implements choice
-- expose implicit parameters to the test that follows
let
is_nested_group = isNotTopLevel top_lvl
- try_me inst | isFreeWrtTyVars qtvs inst,
+ try_me inst | isFreeWrtTyVars qtvs' inst,
(is_nested_group || isDict inst) = Free
| otherwise = ReduceMe AddSCs
in
-- See "Notes on implicit parameters, Question 4: top level"
if is_nested_group then
extendLIEs frees `thenM_`
- returnM (varSetElems qtvs, binds)
+ returnM (varSetElems qtvs', binds)
else
let
(non_ips, bad_ips) = partition isClassDict frees
in
addTopIPErrs bndrs bad_ips `thenM_`
extendLIEs non_ips `thenM_`
- returnM (varSetElems qtvs, binds)
+ returnM (varSetElems qtvs', binds)
\end{code}
new_binds = addBind binds w rhs
new_avails = addToFM avails w (LinRhss rhss)
+ -- get_root is just used for Linear
get_root irreds frees (Given id _) w = returnM (irreds, frees, id)
get_root irreds frees Irred w = cloneDict w `thenM` \ w' ->
returnM (w':irreds, frees, instToId w')
returnM (L span (VarBind x (mk_app span split_id rhs)),
[mk_fs_app span fst_id ty x, mk_fs_app span snd_id ty x])
-mk_fs_app span id ty var = L span (HsVar id) `mkHsTyApp` [ty,ty] `mkHsApp` (L span (HsVar var))
+mk_fs_app span id ty var = nlHsTyApp id [ty,ty] `mkHsApp` (L span (HsVar var))
mk_app span id rhs = L span (HsApp (L span (HsVar id)) rhs)
\begin{code}
reduceList (n,stack) try_me wanteds state
- | n > opt_MaxContextReductionDepth
- = failWithTc (reduceDepthErr n stack)
-
- | otherwise
- =
+ = do { dopts <- getDOpts
#ifdef DEBUG
- (if n > 8 then
- pprTrace "Interesting! Context reduction stack deeper than 8:"
- (int n $$ ifPprDebug (nest 2 (pprStack stack)))
- else (\x->x))
+ ; if n > 8 then
+ dumpTcRn (text "Interesting! Context reduction stack deeper than 8:"
+ <+> (int n $$ ifPprDebug (nest 2 (pprStack stack))))
+ else return ()
#endif
- go wanteds state
+ ; if n >= ctxtStkDepth dopts then
+ failWithTc (reduceDepthErr n stack)
+ else
+ go wanteds state }
where
- go [] state = returnM state
- go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenM` \ state' ->
- go ws state'
+ go [] state = return state
+ go (w:ws) state = do { state' <- reduce (n+1, w:stack) try_me w state
+ ; go ws state' }
-- Base case: we're done!
reduce stack try_me wanted avails
| is_given sc_dict = return avails
| otherwise = addSCs is_loop avails' sc_dict
where
- sc_sel_rhs = mkHsDictApp (mkHsTyApp (L (instSpan dict) (HsVar sc_sel)) tys) [instToId dict]
+ sc_sel_rhs = L (instSpan dict) (HsCoerce co_fn (HsVar sc_sel))
+ co_fn = mkInstCoFn tys [dict]
avails' = addToFM avails sc_dict (Rhs sc_sel_rhs [dict])
is_given :: Inst -> Bool
\begin{code}
tcSimplifyTop, tcSimplifyInteractive :: [Inst] -> TcM TcDictBinds
tcSimplifyTop wanteds
- = tc_simplify_top doc False {- Not interactive loop -} AddSCs wanteds
+ = do { ext_default <- doptM Opt_ExtendedDefaultRules
+ ; tc_simplify_top doc ext_default AddSCs wanteds }
where
doc = text "tcSimplifyTop"
-- The TcLclEnv should be valid here, solely to improve
-- error message generation for the monomorphism restriction
-tc_simplify_top doc is_interactive want_scs wanteds
+tc_simplify_top doc use_extended_defaulting want_scs wanteds
= do { lcl_env <- getLclEnv
; traceTc (text "tcSimplifyTop" <+> ppr (lclEnvElts lcl_env))
= not (bad_tyvars `intersectsVarSet` tyVarsOfInst (head ds))
&& defaultable_classes (map get_clas ds)
defaultable_classes clss
- | is_interactive = any isInteractiveClass clss
- | otherwise = all isStandardClass clss && any isNumericClass clss
+ | use_extended_defaulting = any isInteractiveClass clss
+ | otherwise = all isStandardClass clss && any isNumericClass clss
isInteractiveClass cls = isNumericClass cls
|| (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey])
- -- In interactive mode, we default Show a to Show ()
- -- to avoid graututious errors on "show []"
+ -- In interactive mode, or with -fextended-default-rules,
+ -- we default Show a to Show () to avoid graututious errors on "show []"
-- Collect together all the bad guys
ptext SLIT("to the") <+> what] ]
fix2 | null instance_dicts = []
- | otherwise = [ ptext SLIT("add an instance declaration for")
- <+> pprDictsTheta instance_dicts ]
+ | otherwise = [ sep [ptext SLIT("add an instance declaration for"),
+ pprDictsTheta instance_dicts] ]
instance_dicts = [d | d <- dicts, isClassDict d, not (isTyVarDict d)]
-- Insts for which it is worth suggesting an adding an instance declaration
-- Exclude implicit parameters, and tyvar dicts
reduceDepthErr n stack
= vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
- ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
+ ptext SLIT("Use -fcontext-stack=N to increase stack size to N"),
nest 4 (pprStack stack)]
pprStack stack = vcat (map pprInstInFull stack)
projects / ghc-hetmet.git / blobdiff