-data Avails = Avails !ImprovementDone !AvailEnv
-
-type ImprovementDone = Bool -- True <=> some unification has happened
- -- so some Irreds might now be reducible
- -- keys that are now
-
-type AvailEnv = FiniteMap Inst AvailHow
-data AvailHow
- = IsIrred TcId -- Used for irreducible dictionaries,
- -- which are going to be lambda bound
-
- | Given TcId -- Used for dictionaries for which we have a binding
- -- e.g. those "given" in a signature
-
- | Rhs -- Used when there is a RHS
- (LHsExpr TcId) -- The RHS
- [Inst] -- Insts free in the RHS; we need these too
-
-instance Outputable Avails where
- ppr = pprAvails
-
-pprAvails (Avails imp avails)
- = vcat [ ptext SLIT("Avails") <> (if imp then ptext SLIT("[improved]") else empty)
- , nest 2 (vcat [sep [ppr inst, nest 2 (equals <+> ppr avail)]
- | (inst,avail) <- fmToList avails ])]
-
-instance Outputable AvailHow where
- ppr = pprAvail
-
--------------------------
-pprAvail :: AvailHow -> SDoc
-pprAvail (IsIrred x) = text "Irred" <+> ppr x
-pprAvail (Given x) = text "Given" <+> ppr x
-pprAvail (Rhs rhs bs) = text "Rhs" <+> ppr rhs <+> braces (ppr bs)
-
--------------------------
-extendAvailEnv :: AvailEnv -> Inst -> AvailHow -> AvailEnv
-extendAvailEnv env inst avail = addToFM env inst avail
-
-findAvailEnv :: AvailEnv -> Inst -> Maybe AvailHow
-findAvailEnv env wanted = lookupFM env wanted
- -- NB 1: the Ord instance of Inst compares by the class/type info
- -- *not* by unique. So
- -- d1::C Int == d2::C Int
-
-emptyAvails :: Avails
-emptyAvails = Avails False emptyFM
-
-findAvail :: Avails -> Inst -> Maybe AvailHow
-findAvail (Avails _ avails) wanted = findAvailEnv avails wanted
-
-elemAvails :: Inst -> Avails -> Bool
-elemAvails wanted (Avails _ avails) = wanted `elemFM` avails
-
-extendAvails :: Avails -> Inst -> AvailHow -> TcM Avails
--- Does improvement
-extendAvails avails@(Avails imp env) inst avail
- = do { imp1 <- tcImproveOne avails inst -- Do any improvement
- ; return (Avails (imp || imp1) (extendAvailEnv env inst avail)) }
-
-availsInsts :: Avails -> [Inst]
-availsInsts (Avails _ avails) = keysFM avails
-
-availsImproved (Avails imp _) = imp
-
-updateImprovement :: Avails -> Avails -> Avails
--- (updateImprovement a1 a2) sets a1's improvement flag from a2
-updateImprovement (Avails _ avails1) (Avails imp2 _) = Avails imp2 avails1
-\end{code}
-
-Extracting the bindings from a bunch of Avails.
-The bindings do *not* come back sorted in dependency order.
-We assume that they'll be wrapped in a big Rec, so that the
-dependency analyser can sort them out later
-
-\begin{code}
-extractResults :: Avails
- -> [Inst] -- Wanted
- -> TcM ( TcDictBinds, -- Bindings
- [Inst]) -- Irreducible ones
-
-extractResults (Avails _ avails) wanteds
- = go avails emptyBag [] wanteds
- where
- go :: AvailEnv -> TcDictBinds -> [Inst] -> [Inst]
- -> TcM (TcDictBinds, [Inst])
- go avails binds irreds []
- = returnM (binds, irreds)
-
- go avails binds irreds (w:ws)
- = case findAvailEnv avails w of
- Nothing -> pprTrace "Urk: extractResults" (ppr w) $
- go avails binds irreds ws
-
- Just (Given id)
- | id == w_id -> go avails binds irreds ws
- | otherwise -> go avails (addBind binds w_id (nlHsVar id)) irreds ws
- -- The sought Id can be one of the givens, via a superclass chain
- -- and then we definitely don't want to generate an x=x binding!
-
- Just (IsIrred id)
- | id == w_id -> go (add_given avails w) binds (w:irreds) ws
- | otherwise -> go avails (addBind binds w_id (nlHsVar id)) irreds ws
- -- The add_given handles the case where we want (Ord a, Eq a), and we
- -- don't want to emit *two* Irreds for Ord a, one via the superclass chain
- -- This showed up in a dupliated Ord constraint in the error message for
- -- test tcfail043
-
- Just (Rhs rhs ws') -> go (add_given avails w) new_binds irreds (ws' ++ ws)
- where
- new_binds = addBind binds w_id rhs
- where
- w_id = instToId w
-
- add_given avails w = extendAvailEnv avails w (Given (instToId w))
- -- Don't add the same binding twice
-
-addBind binds id rhs = binds `unionBags` unitBag (L (getSrcSpan id) (VarBind id rhs))
-\end{code}
-
-
-Note [No superclasses for Stop]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we decide not to reduce an Inst -- the 'WhatToDo' --- we still
-add it to avails, so that any other equal Insts will be commoned up
-right here. However, we do *not* add superclasses. If we have
- df::Floating a
- dn::Num a
-but a is not bound here, then we *don't* want to derive dn from df
-here lest we lose sharing.
-
-\begin{code}
-addWanted :: WantSCs -> Avails -> Inst -> LHsExpr TcId -> [Inst] -> TcM Avails
-addWanted want_scs avails wanted rhs_expr wanteds
- = addAvailAndSCs want_scs avails wanted avail
- where
- avail = Rhs rhs_expr wanteds
-
-addGiven :: Avails -> Inst -> TcM Avails
-addGiven avails given = addAvailAndSCs AddSCs avails given (Given (instToId given))
- -- Always add superclasses for 'givens'
- --
- -- 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
-
-addRefinedGiven :: Refinement -> ([Inst], Avails) -> Inst -> TcM ([Inst], Avails)
-addRefinedGiven reft (refined_givens, avails) given
- | isDict given -- We sometimes have 'given' methods, but they
- -- are always optional, so we can drop them
- , let pred = dictPred given
- , isRefineablePred pred -- See Note [ImplicInst rigidity]
- , Just (co, pred) <- refinePred reft pred
- = do { new_given <- newDictBndr (instLoc given) pred
- ; let rhs = L (instSpan given) $
- HsWrap (WpCo co) (HsVar (instToId given))
- ; avails <- addAvailAndSCs AddSCs avails new_given (Rhs rhs [given])
- ; return (new_given:refined_givens, avails) }
- -- ToDo: the superclasses of the original given all exist in Avails
- -- so we could really just cast them, but it's more awkward to do,
- -- and hopefully the optimiser will spot the duplicated work
- | otherwise
- = return (refined_givens, avails)
-\end{code}
-
-Note [ImplicInst rigidity]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- C :: forall ab. (Eq a, Ord b) => b -> T a
-
- ...(case x of C v -> <body>)...
-
-From the case (where x::T ty) we'll get an implication constraint
- forall b. (Eq ty, Ord b) => <body-constraints>
-Now suppose <body-constraints> itself has an implication constraint
-of form
- forall c. <reft> => <payload>
-Then, we can certainly apply the refinement <reft> to the Ord b, becuase it is
-existential, but we probably should not apply it to the (Eq ty) because it may
-be wobbly. Hence the isRigidInst
-
-@Insts@ are ordered by their class/type info, rather than by their
-unique. This allows the context-reduction mechanism to use standard finite
-maps to do their stuff. It's horrible that this code is here, rather
-than with the Avails handling stuff in TcSimplify
-
-\begin{code}
-addIrred :: WantSCs -> Avails -> Inst -> TcM Avails
-addIrred want_scs avails irred = ASSERT2( not (irred `elemAvails` avails), ppr irred $$ ppr avails )
- addAvailAndSCs want_scs avails irred (IsIrred (instToId irred))
-
-addAvailAndSCs :: WantSCs -> Avails -> Inst -> AvailHow -> TcM Avails
-addAvailAndSCs want_scs avails inst avail
- | not (isClassDict inst) = extendAvails avails inst avail
- | NoSCs <- want_scs = extendAvails avails inst avail
- | otherwise = do { traceTc (text "addAvailAndSCs" <+> vcat [ppr inst, ppr deps])
- ; avails' <- extendAvails avails inst avail
- ; addSCs is_loop avails' inst }
- where
- is_loop pred = any (`tcEqType` mkPredTy pred) dep_tys
- -- Note: this compares by *type*, not by Unique
- deps = findAllDeps (unitVarSet (instToId inst)) avail
- dep_tys = map idType (varSetElems deps)
-
- findAllDeps :: IdSet -> AvailHow -> IdSet
- -- Find all the Insts that this one depends on
- -- See Note [SUPERCLASS-LOOP 2]
- -- Watch out, though. Since the avails may contain loops
- -- (see Note [RECURSIVE DICTIONARIES]), so we need to track the ones we've seen so far
- findAllDeps so_far (Rhs _ kids) = foldl find_all so_far kids
- findAllDeps so_far other = so_far
-
- find_all :: IdSet -> Inst -> IdSet
- find_all so_far kid
- | kid_id `elemVarSet` so_far = so_far
- | Just avail <- findAvail avails kid = findAllDeps so_far' avail
- | otherwise = so_far'
- where
- so_far' = extendVarSet so_far kid_id -- Add the new kid to so_far
- kid_id = instToId kid
-
-addSCs :: (TcPredType -> Bool) -> Avails -> Inst -> TcM Avails
- -- Add all the superclasses of the Inst to Avails
- -- The first param says "dont do this because the original thing
- -- depends on this one, so you'd build a loop"
- -- Invariant: the Inst is already in Avails.
-
-addSCs is_loop avails dict
- = ASSERT( isDict dict )
- do { sc_dicts <- newDictBndrs (instLoc dict) sc_theta'
- ; foldlM add_sc avails (zipEqual "add_scs" sc_dicts sc_sels) }
- where
- (clas, tys) = getDictClassTys dict
- (tyvars, sc_theta, sc_sels, _) = classBigSig clas
- sc_theta' = substTheta (zipTopTvSubst tyvars tys) sc_theta
-
- add_sc avails (sc_dict, sc_sel)
- | is_loop (dictPred sc_dict) = return avails -- See Note [SUPERCLASS-LOOP 2]
- | is_given sc_dict = return avails
- | otherwise = do { avails' <- extendAvails avails sc_dict (Rhs sc_sel_rhs [dict])
- ; addSCs is_loop avails' sc_dict }
- where
- sc_sel_rhs = L (instSpan dict) (HsWrap co_fn (HsVar sc_sel))
- co_fn = WpApp (instToId dict) <.> mkWpTyApps tys
-
- is_given :: Inst -> Bool
- is_given sc_dict = case findAvail avails sc_dict of
- Just (Given _) -> True -- Given is cheaper than superclass selection
- other -> False
-\end{code}
-
-%************************************************************************
-%* *
-\section{tcSimplifyTop: defaulting}
-%* *
-%************************************************************************
-
-
-@tcSimplifyTop@ is called once per module to simplify all the constant
-and ambiguous Insts.
-
-We need to be careful of one case. Suppose we have
-
- instance Num a => Num (Foo a b) where ...
-
-and @tcSimplifyTop@ is given a constraint (Num (Foo x y)). Then it'll simplify
-to (Num x), and default x to Int. But what about y??
-
-It's OK: the final zonking stage should zap y to (), which is fine.
-
-
-\begin{code}
-tcSimplifyTop, tcSimplifyInteractive :: [Inst] -> TcM TcDictBinds
-tcSimplifyTop wanteds
- = tc_simplify_top doc False wanteds
- where
- doc = text "tcSimplifyTop"
-
-tcSimplifyInteractive wanteds
- = tc_simplify_top doc True wanteds
- where
- doc = text "tcSimplifyInteractive"
-
--- The TcLclEnv should be valid here, solely to improve
--- error message generation for the monomorphism restriction
-tc_simplify_top doc interactive wanteds
- = do { dflags <- getDOpts
- ; wanteds <- mapM zonkInst wanteds
- ; mapM_ zonkTopTyVar (varSetElems (tyVarsOfInsts wanteds))
-
- ; (irreds1, binds1) <- tryHardCheckLoop doc1 wanteds
- ; (irreds2, binds2) <- approximateImplications doc2 (\d -> True) irreds1
-
- -- Use the defaulting rules to do extra unification
- -- NB: irreds2 are already zonked
- ; (irreds3, binds3) <- disambiguate doc3 interactive dflags irreds2
-
- -- Deal with implicit parameters
- ; let (bad_ips, non_ips) = partition isIPDict irreds3
- (ambigs, others) = partition isTyVarDict non_ips
-
- ; topIPErrs bad_ips -- Can arise from f :: Int -> Int
- -- f x = x + ?y
- ; addNoInstanceErrs others
- ; addTopAmbigErrs ambigs
-
- ; return (binds1 `unionBags` binds2 `unionBags` binds3) }
- where
- doc1 = doc <+> ptext SLIT("(first round)")
- doc2 = doc <+> ptext SLIT("(approximate)")
- doc3 = doc <+> ptext SLIT("(disambiguate)")
-\end{code}
-
-If a dictionary constrains a type variable which is
- * not mentioned in the environment
- * and not mentioned in the type of the expression
-then it is ambiguous. No further information will arise to instantiate
-the type variable; nor will it be generalised and turned into an extra
-parameter to a function.
-
-It is an error for this to occur, except that Haskell provided for
-certain rules to be applied in the special case of numeric types.
-Specifically, if
- * at least one of its classes is a numeric class, and
- * all of its classes are numeric or standard
-then the type variable can be defaulted to the first type in the
-default-type list which is an instance of all the offending classes.
-
-So here is the function which does the work. It takes the ambiguous
-dictionaries and either resolves them (producing bindings) or
-complains. It works by splitting the dictionary list by type
-variable, and using @disambigOne@ to do the real business.
-
-@disambigOne@ assumes that its arguments dictionaries constrain all
-the same type variable.
-
-ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
-@()@ instead of @Int@. I reckon this is the Right Thing to do since
-the most common use of defaulting is code like:
-\begin{verbatim}
- _ccall_ foo `seqPrimIO` bar
-\end{verbatim}
-Since we're not using the result of @foo@, the result if (presumably)
-@void@.
-
-\begin{code}
-disambiguate :: SDoc -> Bool -> DynFlags -> [Inst] -> TcM ([Inst], TcDictBinds)
- -- Just does unification to fix the default types
- -- The Insts are assumed to be pre-zonked
-disambiguate doc interactive dflags insts
- | null insts
- = return (insts, emptyBag)
-
- | null defaultable_groups
- = do { traceTc (text "disambigutate" <+> vcat [ppr unaries, ppr bad_tvs, ppr defaultable_groups])
- ; return (insts, emptyBag) }
-
- | otherwise
- = do { -- Figure out what default types to use
- default_tys <- getDefaultTys extended_defaulting ovl_strings
-
- ; traceTc (text "disambigutate" <+> vcat [ppr unaries, ppr bad_tvs, ppr defaultable_groups])
- ; mapM_ (disambigGroup default_tys) defaultable_groups
-
- -- disambigGroup does unification, hence try again
- ; tryHardCheckLoop doc insts }
-
- where
- extended_defaulting = interactive || dopt Opt_ExtendedDefaultRules dflags
- ovl_strings = dopt Opt_OverloadedStrings dflags
-
- unaries :: [(Inst, Class, TcTyVar)] -- (C tv) constraints
- bad_tvs :: TcTyVarSet -- Tyvars mentioned by *other* constraints
- (unaries, bad_tvs_s) = partitionWith find_unary insts
- bad_tvs = unionVarSets bad_tvs_s
-
- -- Finds unary type-class constraints
- find_unary d@(Dict {tci_pred = ClassP cls [ty]})
- | Just tv <- tcGetTyVar_maybe ty = Left (d,cls,tv)
- find_unary inst = Right (tyVarsOfInst inst)
-
- -- Group by type variable
- defaultable_groups :: [[(Inst,Class,TcTyVar)]]
- defaultable_groups = filter defaultable_group (equivClasses cmp_tv unaries)
- cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2
-
- defaultable_group :: [(Inst,Class,TcTyVar)] -> Bool
- defaultable_group ds@((_,_,tv):_)
- = isTyConableTyVar tv -- Note [Avoiding spurious errors]
- && not (tv `elemVarSet` bad_tvs)
- && defaultable_classes [c | (_,c,_) <- ds]
- defaultable_group [] = panic "defaultable_group"
-
- defaultable_classes clss
- | extended_defaulting = any isInteractiveClass clss
- | otherwise = all is_std_class clss && (any is_num_class clss)
-
- -- In interactive mode, or with -fextended-default-rules,
- -- we default Show a to Show () to avoid graututious errors on "show []"
- isInteractiveClass cls
- = is_num_class cls || (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey])
-
- is_num_class cls = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey))
- -- is_num_class adds IsString to the standard numeric classes,
- -- when -foverloaded-strings is enabled
-
- is_std_class cls = isStandardClass cls || (ovl_strings && (cls `hasKey` isStringClassKey))
- -- Similarly is_std_class
-
------------------------
-disambigGroup :: [Type] -- The default types
- -> [(Inst,Class,TcTyVar)] -- All standard classes of form (C a)
- -> TcM () -- Just does unification, to fix the default types
-
-disambigGroup default_tys dicts
- = try_default default_tys
- where
- (_,_,tyvar) = head dicts -- Should be non-empty
- classes = [c | (_,c,_) <- dicts]
-
- try_default [] = return ()
- try_default (default_ty : default_tys)
- = tryTcLIE_ (try_default default_tys) $
- do { tcSimplifyDefault [mkClassPred clas [default_ty] | clas <- classes]
- -- This may fail; then the tryTcLIE_ kicks in
- -- Failure here is caused by there being no type in the
- -- default list which can satisfy all the ambiguous classes.
- -- For example, if Real a is reqd, but the only type in the
- -- default list is Int.
-
- -- After this we can't fail
- ; warnDefault dicts default_ty
- ; unifyType default_ty (mkTyVarTy tyvar) }
-
-
------------------------
-getDefaultTys :: Bool -> Bool -> TcM [Type]
-getDefaultTys extended_deflts ovl_strings
- = do { mb_defaults <- getDeclaredDefaultTys
- ; case mb_defaults of {
- Just tys -> return tys ; -- User-supplied defaults
- Nothing -> do
-
- -- No use-supplied default
- -- Use [Integer, Double], plus modifications
- { integer_ty <- tcMetaTy integerTyConName
- ; checkWiredInTyCon doubleTyCon
- ; string_ty <- tcMetaTy stringTyConName
- ; return (opt_deflt extended_deflts unitTy
- -- Note [Default unitTy]
- ++
- [integer_ty,doubleTy]
- ++
- opt_deflt ovl_strings string_ty) } } }
- where
- opt_deflt True ty = [ty]
- opt_deflt False ty = []
-\end{code}
-
-Note [Default unitTy]
-~~~~~~~~~~~~~~~~~~~~~
-In interative mode (or with -fextended-default-rules) we add () as the first type we
-try when defaulting. This has very little real impact, except in the following case.
-Consider:
- Text.Printf.printf "hello"
-This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't
-want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to
-default the 'a' to (), rather than to Integer (which is what would otherwise happen;
-and then GHCi doesn't attempt to print the (). So in interactive mode, we add
-() to the list of defaulting types. See Trac #1200.
-
-Note [Avoiding spurious errors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When doing the unification for defaulting, we check for skolem
-type variables, and simply don't default them. For example:
- f = (*) -- Monomorphic
- g :: Num a => a -> a
- g x = f x x
-Here, we get a complaint when checking the type signature for g,
-that g isn't polymorphic enough; but then we get another one when
-dealing with the (Num a) context arising from f's definition;
-we try to unify a with Int (to default it), but find that it's
-already been unified with the rigid variable from g's type sig
-
-
-%************************************************************************
-%* *
-\subsection[simple]{@Simple@ versions}
-%* *
-%************************************************************************
-
-Much simpler versions when there are no bindings to make!
-
-@tcSimplifyThetas@ simplifies class-type constraints formed by
-@deriving@ declarations and when specialising instances. We are
-only interested in the simplified bunch of class/type constraints.
-
-It simplifies to constraints of the form (C a b c) where
-a,b,c are type variables. This is required for the context of
-instance declarations.
-
-\begin{code}
-tcSimplifyDeriv :: InstOrigin
- -> [TyVar]
- -> ThetaType -- Wanted
- -> TcM ThetaType -- Needed
--- Given instance (wanted) => C inst_ty
--- Simplify 'wanted' as much as possible
--- The inst_ty is needed only for the termination check
-
-tcSimplifyDeriv orig tyvars theta
- = do { (tvs, _, tenv) <- tcInstTyVars tyvars
- -- The main loop may do unification, and that may crash if
- -- it doesn't see a TcTyVar, so we have to instantiate. Sigh
- -- ToDo: what if two of them do get unified?
- ; wanteds <- newDictBndrsO orig (substTheta tenv theta)
- ; (irreds, _) <- tryHardCheckLoop doc wanteds
-
- ; let (tv_dicts, others) = partition isTyVarDict irreds
- ; addNoInstanceErrs others
-
- ; let rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars)
- simpl_theta = substTheta rev_env (map dictPred tv_dicts)
- -- This reverse-mapping is a pain, but the result
- -- should mention the original TyVars not TcTyVars
-
- ; return simpl_theta }
- where
- doc = ptext SLIT("deriving classes for a data type")
-\end{code}
-
-Note [Exotic derived instance contexts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- data T a b c = MkT (Foo a b c) deriving( Eq )
- instance (C Int a, Eq b, Eq c) => Eq (Foo a b c)
-
-Notice that this instance (just) satisfies the Paterson termination
-conditions. Then we *could* derive an instance decl like this:
-
- instance (C Int a, Eq b, Eq c) => Eq (T a b c)
-
-even though there is no instance for (C Int a), because there just
-*might* be an instance for, say, (C Int Bool) at a site where we
-need the equality instance for T's.
-
-However, this seems pretty exotic, and it's quite tricky to allow
-this, and yet give sensible error messages in the (much more common)
-case where we really want that instance decl for C.
-
-So for now we simply require that the derived instance context
-should have only type-variable constraints.
-
-Here is another example:
- data Fix f = In (f (Fix f)) deriving( Eq )
-Here, if we are prepared to allow -fallow-undecidable-instances we
-could derive the instance
- instance Eq (f (Fix f)) => Eq (Fix f)
-but this is so delicate that I don't think it should happen inside
-'deriving'. If you want this, write it yourself!
-
-NB: if you want to lift this condition, make sure you still meet the
-termination conditions! If not, the deriving mechanism generates
-larger and larger constraints. Example:
- data Succ a = S a
- data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show
-
-Note the lack of a Show instance for Succ. First we'll generate
- instance (Show (Succ a), Show a) => Show (Seq a)
-and then
- instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a)
-and so on. Instead we want to complain of no instance for (Show (Succ a)).
-
-
-@tcSimplifyDefault@ just checks class-type constraints, essentially;
-used with \tr{default} declarations. We are only interested in
-whether it worked or not.
-
-\begin{code}
-tcSimplifyDefault :: ThetaType -- Wanted; has no type variables in it
- -> TcM ()
-
-tcSimplifyDefault theta
- = newDictBndrsO DefaultOrigin theta `thenM` \ wanteds ->
- tryHardCheckLoop doc wanteds `thenM` \ (irreds, _) ->
- addNoInstanceErrs irreds `thenM_`
- if null irreds then
- returnM ()
- else
- failM
- where
- doc = ptext SLIT("default declaration")
-\end{code}
-
-
-%************************************************************************
-%* *
-\section{Errors and contexts}
-%* *
-%************************************************************************
-
-ToDo: for these error messages, should we note the location as coming
-from the insts, or just whatever seems to be around in the monad just
-now?
-
-\begin{code}
-groupErrs :: ([Inst] -> TcM ()) -- Deal with one group
- -> [Inst] -- The offending Insts
- -> TcM ()
--- Group together insts with the same origin
--- We want to report them together in error messages
-
-groupErrs report_err []
- = returnM ()
-groupErrs report_err (inst:insts)
- = do_one (inst:friends) `thenM_`
- groupErrs report_err others
-
- where
- -- (It may seem a bit crude to compare the error messages,
- -- but it makes sure that we combine just what the user sees,
- -- and it avoids need equality on InstLocs.)
- (friends, others) = partition is_friend insts
- loc_msg = showSDoc (pprInstLoc (instLoc inst))
- is_friend friend = showSDoc (pprInstLoc (instLoc friend)) == loc_msg
- do_one insts = addInstCtxt (instLoc (head insts)) (report_err insts)
- -- Add location and context information derived from the Insts
-
--- Add the "arising from..." part to a message about bunch of dicts
-addInstLoc :: [Inst] -> Message -> Message
-addInstLoc insts msg = msg $$ nest 2 (pprInstArising (head insts))
-
-addTopIPErrs :: [Name] -> [Inst] -> TcM ()
-addTopIPErrs bndrs []
- = return ()
-addTopIPErrs bndrs ips
- = do { dflags <- getDOpts
- ; addErrTcM (tidy_env, mk_msg dflags tidy_ips) }
- where
- (tidy_env, tidy_ips) = tidyInsts ips
- mk_msg dflags ips
- = vcat [sep [ptext SLIT("Implicit parameters escape from"),
- nest 2 (ptext SLIT("the monomorphic top-level binding")
- <> plural bndrs <+> ptext SLIT("of")
- <+> pprBinders bndrs <> colon)],
- nest 2 (vcat (map ppr_ip ips)),
- monomorphism_fix dflags]
- ppr_ip ip = pprPred (dictPred ip) <+> pprInstArising ip
-
-topIPErrs :: [Inst] -> TcM ()
-topIPErrs dicts
- = groupErrs report tidy_dicts
- where
- (tidy_env, tidy_dicts) = tidyInsts dicts
- report dicts = addErrTcM (tidy_env, mk_msg dicts)
- mk_msg dicts = addInstLoc dicts (ptext SLIT("Unbound implicit parameter") <>
- plural tidy_dicts <+> pprDictsTheta tidy_dicts)
-
-addNoInstanceErrs :: [Inst] -- Wanted (can include implications)
- -> TcM ()
-addNoInstanceErrs insts
- = do { let (tidy_env, tidy_insts) = tidyInsts insts
- ; reportNoInstances tidy_env Nothing tidy_insts }
-
-reportNoInstances
- :: TidyEnv
- -> Maybe (InstLoc, [Inst]) -- Context
- -- Nothing => top level
- -- Just (d,g) => d describes the construct
- -- with givens g
- -> [Inst] -- What is wanted (can include implications)
- -> TcM ()
-
-reportNoInstances tidy_env mb_what insts
- = groupErrs (report_no_instances tidy_env mb_what) insts
-
-report_no_instances tidy_env mb_what insts
- = do { inst_envs <- tcGetInstEnvs
- ; let (implics, insts1) = partition isImplicInst insts
- (insts2, overlaps) = partitionWith (check_overlap inst_envs) insts1
- ; traceTc (text "reportNoInstnces" <+> vcat
- [ppr implics, ppr insts1, ppr insts2])
- ; mapM_ complain_implic implics
- ; mapM_ (\doc -> addErrTcM (tidy_env, doc)) overlaps
- ; groupErrs complain_no_inst insts2 }
- where
- complain_no_inst insts = addErrTcM (tidy_env, mk_no_inst_err insts)
-
- complain_implic inst -- Recurse!
- = reportNoInstances tidy_env
- (Just (tci_loc inst, tci_given inst))
- (tci_wanted inst)
-
- check_overlap :: (InstEnv,InstEnv) -> Inst -> Either Inst SDoc
- -- Right msg => overlap message
- -- Left inst => no instance
- check_overlap inst_envs wanted
- | not (isClassDict wanted) = Left wanted
- | otherwise
- = case lookupInstEnv inst_envs clas tys of
- -- The case of exactly one match and no unifiers means
- -- a successful lookup. That can't happen here, becuase
- -- dicts only end up here if they didn't match in Inst.lookupInst
-#ifdef DEBUG
- ([m],[]) -> pprPanic "reportNoInstance" (ppr wanted)
-#endif
- ([], _) -> Left wanted -- No match
- res -> Right (mk_overlap_msg wanted res)
- where
- (clas,tys) = getDictClassTys wanted
-
- mk_overlap_msg dict (matches, unifiers)
- = vcat [ addInstLoc [dict] ((ptext SLIT("Overlapping instances for")
- <+> pprPred (dictPred dict))),
- sep [ptext SLIT("Matching instances") <> colon,
- nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])],
- ASSERT( not (null matches) )
- if not (isSingleton matches)
- then -- Two or more matches
- empty
- else -- One match, plus some unifiers
- ASSERT( not (null unifiers) )
- parens (vcat [ptext SLIT("The choice depends on the instantiation of") <+>
- quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))),
- ptext SLIT("Use -fallow-incoherent-instances to use the first choice above")])]
- where
- ispecs = [ispec | (ispec, _) <- matches]
-
- mk_no_inst_err insts
- | null insts = empty
-
- | Just (loc, givens) <- mb_what, -- Nested (type signatures, instance decls)
- not (isEmptyVarSet (tyVarsOfInsts insts))
- = 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) ]
-
- | otherwise -- Top level
- = vcat [ addInstLoc insts $
- ptext SLIT("No instance") <> plural insts
- <+> ptext SLIT("for") <+> pprDictsTheta insts
- , show_fixes fixes2 ]
-
- where
- fix1 loc = sep [ ptext SLIT("add") <+> pprDictsTheta insts
- <+> ptext SLIT("to the context of"),
- nest 2 (ppr (instLocOrigin loc)) ]
- -- I'm not sure it helps to add the location
- -- nest 2 (ptext SLIT("at") <+> ppr (instLocSpan loc)) ]
-
- fixes2 | null instance_dicts = []
- | otherwise = [sep [ptext SLIT("add an instance declaration for"),
- pprDictsTheta instance_dicts]]
- instance_dicts = [d | d <- insts, isClassDict d, not (isTyVarDict d)]
- -- Insts for which it is worth suggesting an adding an instance declaration
- -- Exclude implicit parameters, and tyvar dicts
-
- show_fixes :: [SDoc] -> SDoc
- show_fixes [] = empty
- show_fixes (f:fs) = sep [ptext SLIT("Possible fix:"),
- nest 2 (vcat (f : map (ptext SLIT("or") <+>) fs))]
-
-addTopAmbigErrs dicts
--- Divide into groups that share a common set of ambiguous tyvars
- = ifErrsM (return ()) $ -- Only report ambiguity if no other errors happened
- -- See Note [Avoiding spurious errors]
- mapM_ report (equivClasses cmp [(d, tvs_of d) | d <- tidy_dicts])
- where
- (tidy_env, tidy_dicts) = tidyInsts dicts
-
- tvs_of :: Inst -> [TcTyVar]
- tvs_of d = varSetElems (tyVarsOfInst d)
- cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
-
- report :: [(Inst,[TcTyVar])] -> TcM ()
- report pairs@((inst,tvs) : _) -- The pairs share a common set of ambiguous tyvars
- = mkMonomorphismMsg tidy_env tvs `thenM` \ (tidy_env, mono_msg) ->
- setSrcSpan (instSpan inst) $
- -- the location of the first one will do for the err message
- addErrTcM (tidy_env, msg $$ mono_msg)
- where
- dicts = map fst pairs
- msg = sep [text "Ambiguous type variable" <> plural tvs <+>
- pprQuotedList tvs <+> in_msg,
- nest 2 (pprDictsInFull dicts)]
- in_msg = text "in the constraint" <> plural dicts <> colon
- report [] = panic "addTopAmbigErrs"
-
-
-mkMonomorphismMsg :: TidyEnv -> [TcTyVar] -> TcM (TidyEnv, Message)
--- There's an error with these Insts; if they have free type variables
--- it's probably caused by the monomorphism restriction.
--- Try to identify the offending variable
--- ASSUMPTION: the Insts are fully zonked
-mkMonomorphismMsg tidy_env inst_tvs
- = do { dflags <- getDOpts
- ; (tidy_env, docs) <- findGlobals (mkVarSet inst_tvs) tidy_env
- ; return (tidy_env, mk_msg dflags docs) }
- where
- mk_msg _ _ | any isRuntimeUnk inst_tvs
- = vcat [ptext SLIT("Cannot resolve unknown runtime types:") <+>
- (pprWithCommas ppr inst_tvs),
- ptext SLIT("Use :print or :force to determine these types")]
- mk_msg _ [] = ptext SLIT("Probable fix: add a type signature that fixes these type variable(s)")
- -- This happens in things like
- -- f x = show (read "foo")
- -- where monomorphism doesn't play any role
- mk_msg dflags docs
- = vcat [ptext SLIT("Possible cause: the monomorphism restriction applied to the following:"),
- nest 2 (vcat docs),
- monomorphism_fix dflags]
-
-isRuntimeUnk :: TcTyVar -> Bool
-isRuntimeUnk x | SkolemTv RuntimeUnkSkol <- tcTyVarDetails x = True
- | otherwise = False
-
-monomorphism_fix :: DynFlags -> SDoc
-monomorphism_fix dflags
- = ptext SLIT("Probable fix:") <+> vcat
- [ptext SLIT("give these definition(s) an explicit type signature"),
- if dopt Opt_MonomorphismRestriction dflags
- then ptext SLIT("or use -fno-monomorphism-restriction")
- else empty] -- Only suggest adding "-fno-monomorphism-restriction"
- -- if it is not already set!
-
-warnDefault ups default_ty
- = doptM Opt_WarnTypeDefaults `thenM` \ warn_flag ->
- addInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg)
- where
- dicts = [d | (d,_,_) <- ups]
-
- -- Tidy them first
- (_, tidy_dicts) = tidyInsts dicts
- warn_msg = vcat [ptext SLIT("Defaulting the following constraint(s) to type") <+>
- quotes (ppr default_ty),
- pprDictsInFull tidy_dicts]
-
-reduceDepthErr n stack
- = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
- ptext SLIT("Use -fcontext-stack=N to increase stack size to N"),
- nest 4 (pprStack stack)]
-
-pprStack stack = vcat (map pprInstInFull stack)
-\end{code}