TcSimplify
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module TcSimplify (
tcSimplifyInfer, tcSimplifyInferCheck,
tcSimplifyCheck, tcSimplifyRestricted,
import HsSyn
import TcRnMonad
+import TcHsSyn ( hsLPatType )
import Inst
import TcEnv
import InstEnv
import TcMType
import TcIface
import TcTyFuns
-import TypeRep
+import DsUtils -- Big-tuple functions
import Var
import Name
import NameSet
import BasicTypes
import VarSet
import VarEnv
-import Module
import FiniteMap
import Bag
import Outputable
import Maybes
import ListSetOps
import Util
-import UniqSet
import SrcLoc
import DynFlags
import FastString
Here is a more complicated example:
-| > class Foo a b | a->b
-| >
-| > class Bar a b | a->b
-| >
-| > data Obj = Obj
-| >
-| > instance Bar Obj Obj
-| >
-| > instance (Bar a b) => Foo a b
-| >
-| > foo:: (Foo a b) => a -> String
-| > foo _ = "works"
-| >
-| > runFoo:: (forall a b. (Foo a b) => a -> w) -> w
-| > runFoo f = f Obj
-|
-| *Test> runFoo foo
-|
-| <interactive>:1:
-| Could not deduce (Bar a b) from the context (Foo a b)
-| arising from use of `foo' at <interactive>:1
-| Probable fix:
-| Add (Bar a b) to the expected type of an expression
-| In the first argument of `runFoo', namely `foo'
-| In the definition of `it': it = runFoo foo
-|
-| Why all of the sudden does GHC need the constraint Bar a b? The
-| function foo didn't ask for that...
+@
+ > class Foo a b | a->b
+ >
+ > class Bar a b | a->b
+ >
+ > data Obj = Obj
+ >
+ > instance Bar Obj Obj
+ >
+ > instance (Bar a b) => Foo a b
+ >
+ > foo:: (Foo a b) => a -> String
+ > foo _ = "works"
+ >
+ > runFoo:: (forall a b. (Foo a b) => a -> w) -> w
+ > runFoo f = f Obj
+
+ *Test> runFoo foo
+
+ <interactive>:1:
+ Could not deduce (Bar a b) from the context (Foo a b)
+ arising from use of `foo' at <interactive>:1
+ Probable fix:
+ Add (Bar a b) to the expected type of an expression
+ In the first argument of `runFoo', namely `foo'
+ In the definition of `it': it = runFoo foo
+
+ Why all of the sudden does GHC need the constraint Bar a b? The
+ function foo didn't ask for that...
+@
The trouble is that to type (runFoo foo), GHC has to solve the problem:
&& isFreeWrtIPs ips inst
-}
+isFreeWrtTyVars :: VarSet -> Inst -> Bool
isFreeWrtTyVars qtvs inst = tyVarsOfInst inst `disjointVarSet` qtvs
+isFreeWrtIPs :: NameSet -> Inst -> Bool
isFreeWrtIPs ips inst = not (any (`elemNameSet` ips) (ipNamesOfInst inst))
\end{code}
tci_given = (eq_givens ++ dict_givens),
tci_wanted = irreds, tci_loc = loc }
; let -- only create binder for dict_irreds
- (eq_irreds, dict_irreds) = partition isEqInst irreds
- n_dict_irreds = length dict_irreds
+ (_, dict_irreds) = partition isEqInst irreds
dict_irred_ids = map instToId dict_irreds
- tup_ty = mkTupleTy Boxed n_dict_irreds (map idType dict_irred_ids)
- pat = TuplePat (map nlVarPat dict_irred_ids) Boxed tup_ty
+ lpat = mkBigLHsPatTup (map (L span . VarPat) dict_irred_ids)
rhs = L span (mkHsWrap co (HsVar (instToId implic_inst)))
co = mkWpApps (map instToId dict_givens)
<.> mkWpTyApps eq_tyvar_cos
<.> mkWpTyApps (mkTyVarTys all_tvs)
bind | [dict_irred_id] <- dict_irred_ids = VarBind dict_irred_id rhs
- | otherwise = PatBind { pat_lhs = L span pat,
+ | otherwise = PatBind { pat_lhs = lpat,
pat_rhs = unguardedGRHSs rhs,
- pat_rhs_ty = tup_ty,
+ pat_rhs_ty = hsLPatType lpat,
bind_fvs = placeHolderNames }
; traceTc $ text "makeImplicationBind" <+> ppr implic_inst
; return ([implic_inst], unitBag (L span bind))
; return (irreds,binds)
}
where
- try_me inst = ReduceMe AddSCs
+ try_me _ = ReduceMe AddSCs
-- Here's the try-hard bit
-----------------------------------------------------------
; return binds1 }
where
env = mkRedEnv (pprInstLoc loc) try_me givens
- try_me inst = ReduceMe NoSCs
+ try_me _ = ReduceMe NoSCs
-- Like tryHardCheckLoop, but with NoSCs
\end{code}
-- BUT do no improvement! See Plan D above
-- HOWEVER, some unification may take place, if we instantiate
-- a method Inst with an equality constraint
- ; let env = mkNoImproveRedEnv doc (\i -> ReduceMe AddSCs)
+ ; let env = mkNoImproveRedEnv doc (\_ -> ReduceMe AddSCs)
; (_imp, _binds, constrained_dicts, elim_skolems)
<- reduceContext env wanteds'
; elim_skolems
given_dicts0
-- 5. Build the Avail mapping from "given_dicts"
- ; (init_state, extra_givens) <- getLIE $ do
+ ; (init_state, _) <- getLIE $ do
{ init_state <- foldlM addGiven emptyAvails given_dicts
; return init_state
}
- -- *** ToDo: what to do with the "extra_givens"? For the
+ -- !!! ToDo: what to do with the "extra_givens"? For the
-- moment I'm simply discarding them, which is probably wrong
-- 6. Solve the *wanted* *dictionary* constraints (not implications)
mapM_ (unif_pr tenv) pairs
unif_pr tenv (ty1,ty2) = unifyType (substTy tenv ty1) (substTy tenv ty2)
-pprEquationDoc (eqn, (p1,w1), (p2,w2)) = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)]
+pprEquationDoc :: (Equation, (PredType, SDoc), (PredType, SDoc)) -> SDoc
+pprEquationDoc (eqn, (p1, _), (p2, _)) = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)]
+mkEqnMsg :: (TcPredType, SDoc) -> (TcPredType, SDoc) -> TidyEnv
+ -> TcM (TidyEnv, SDoc)
mkEqnMsg (pred1,from1) (pred2,from2) tidy_env
= do { pred1' <- zonkTcPredType pred1; pred2' <- zonkTcPredType pred2
; let { pred1'' = tidyPred tidy_env pred1'; pred2'' = tidyPred tidy_env pred2' }
; go ws state' }
-- Base case: we're done!
+reduce :: RedEnv -> Inst -> Avails -> TcM Avails
reduce env wanted avails
-- It's the same as an existing inst, or a superclass thereof
- | Just avail <- findAvail avails wanted
+ | Just _ <- findAvail avails wanted
= do { traceTc (text "reduce: found " <+> ppr wanted)
; return avails
}
= do { res <- lookupSimpleInst wanted
; case res of
GenInst [] rhs -> addWanted AddSCs avails wanted rhs []
- other -> do_this_otherwise avails wanted }
+ _ -> do_this_otherwise avails wanted }
\end{code}
\begin{code}
---------------------------------------------
reduceInst :: RedEnv -> Avails -> Inst -> TcM (Avails, LookupInstResult)
-reduceInst env avails other_inst
+reduceInst _ avails other_inst
= do { result <- lookupSimpleInst other_inst
; return (avails, result) }
\end{code}
tci_tyvars = tvs,
tci_given = extra_givens, tci_wanted = wanteds })
= do { -- Solve the sub-problem
- ; let try_me inst = ReduceMe AddSCs -- Note [Freeness and implications]
+ ; let try_me _ = ReduceMe AddSCs -- Note [Freeness and implications]
env' = env { red_givens = extra_givens ++ red_givens env
, red_doc = sep [ptext (sLit "reduceImplication for")
<+> ppr name,
<.> WpLet (binds `unionBags` bind)
wrap_inline | null dict_ids = idHsWrapper
| otherwise = WpInline
- rhs = mkHsWrap co payload
+ rhs = mkLHsWrap co payload
loc = instLocSpan inst_loc
- payload | [dict_wanted] <- dict_wanteds = HsVar (instToId dict_wanted)
- | otherwise = ExplicitTuple (map (L loc . HsVar . instToId) dict_wanteds) Boxed
+ payload = mkBigLHsTup (map (L loc . HsVar . instToId) dict_wanteds)
; traceTc (vcat [text "reduceImplication" <+> ppr name,
ppr simpler_implic_insts,
text "->" <+> ppr rhs])
- ; return (unitBag (L loc (VarBind (instToId orig_implic) (L loc rhs))),
+ ; return (unitBag (L loc (VarBind (instToId orig_implic) rhs)),
simpler_implic_insts)
}
}
+reduceImplication _ i = pprPanic "reduceImplication" (ppr i)
\end{code}
Note [Always inline implication constraints]
to float the (C Int) out, even though it mentions no type variable in
the constraints!
+One more example: the constraint
+ class C a => D a b
+ instance (C a, E c) => E (a,c)
+
+ constraint: forall b. D Int b => E (Int,c)
+
+You might think that the (D Int b) can't possibly contribute
+to solving (E (Int,c)), since the latter mentions 'c'. But
+in fact it can, because solving the (E (Int,c)) constraint needs
+dictionaries
+ C Int, E c
+and the (C Int) can be satisfied from the superclass of (D Int b).
+So we must still not float (E (Int,c)) out.
+
+To think about: special cases for unary type classes?
+
Note [Pruning the givens in an implication constraint]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we are about to form the implication constraint
forall tvs. Eq a => Ord b
The (Eq a) cannot contribute to the (Ord b), because it has no access to
the type variable 'b'. So we could filter out the (Eq a) from the givens.
+But BE CAREFUL of the examples above in [Freeness and implications].
Doing so would be a bit tidier, but all the implication constraints get
simplified away by the optimiser, so it's no great win. So I don't take
instance Outputable Avails where
ppr = pprAvails
+pprAvails :: Avails -> SDoc
pprAvails (Avails imp avails)
= vcat [ ptext (sLit "Avails") <> (if imp then ptext (sLit "[improved]") else empty)
, nest 2 $ braces $
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
+_availsImproved :: Avails -> ImprovementDone
+_availsImproved (Avails imp _) = imp
\end{code}
Extracting the bindings from a bunch of Avails.
-> DoneEnv -- Has an entry for each inst in the above three sets
-> [Inst] -- Wanted
-> TcM (TcDictBinds, [Inst], [Inst])
- go binds bound_dicts irreds done []
+ go binds bound_dicts irreds _ []
= return (binds, bound_dicts, irreds)
go binds bound_dicts irreds done (w:ws)
-- 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
+ findAllDeps so_far _ = so_far
find_all :: IdSet -> Inst -> IdSet
find_all so_far kid
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
+ _ -> False
-- From the a set of insts obtain all equalities that (transitively) occur in
-- superclass contexts of class constraints (aka the ancestor equalities).
-- The TcLclEnv should be valid here, solely to improve
-- error message generation for the monomorphism restriction
+tc_simplify_top :: SDoc -> Bool -> [Inst] -> TcM (Bag (LHsBind TcId))
tc_simplify_top doc interactive wanteds
= do { dflags <- getDOpts
; wanteds <- zonkInsts wanteds
; (irreds1, binds1) <- tryHardCheckLoop doc1 wanteds
-- ; (irreds1, binds1) <- gentleInferLoop doc1 wanteds
; traceTc (text "tc_simplify_top 1: " <+> ppr irreds1)
- ; (irreds2, binds2) <- approximateImplications doc2 (\d -> True) irreds1
+ ; (irreds2, binds2) <- approximateImplications doc2 (\_ -> True) irreds1
; traceTc (text "tc_simplify_top 2: " <+> ppr irreds2)
-- Use the defaulting rules to do extra unification
| extended_defaulting = any isInteractiveClass clss
| otherwise = all is_std_class clss && (any is_num_class clss)
- -- In interactive mode, or with -fextended-default-rules,
+ -- In interactive mode, or with -XExtendedDefaultRules,
-- we default Show a to Show () to avoid graututious errors on "show []"
isInteractiveClass cls
= is_num_class cls || (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey])
opt_deflt ovl_strings string_ty) } } }
where
opt_deflt True ty = [ty]
- opt_deflt False ty = []
+ opt_deflt False _ = []
\end{code}
Note [Default unitTy]
~~~~~~~~~~~~~~~~~~~~~
-In interative mode (or with -fextended-default-rules) we add () as the first type we
+In interative mode (or with -XExtendedDefaultRules) 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"
-- Group together insts with the same origin
-- We want to report them together in error messages
-groupErrs report_err []
+groupErrs _ []
= return ()
groupErrs report_err (inst:insts)
= do { do_one (inst:friends)
addInstLoc insts msg = msg $$ nest 2 (pprInstArising (head insts))
addTopIPErrs :: [Name] -> [Inst] -> TcM ()
-addTopIPErrs bndrs []
+addTopIPErrs _ []
= return ()
addTopIPErrs bndrs ips
= do { dflags <- getDOpts
reportNoInstances tidy_env mb_what insts
= groupErrs (report_no_instances tidy_env mb_what) insts
+report_no_instances :: TidyEnv -> Maybe (InstLoc, [Inst]) -> [Inst] -> TcM ()
report_no_instances tidy_env mb_what insts
= do { inst_envs <- tcGetInstEnvs
; let (implics, insts1) = partition isImplicInst insts
-- The case of exactly one match and no unifiers means a
-- successful lookup. That can't happen here, because dicts
-- only end up here if they didn't match in Inst.lookupInst
- ([m],[])
+ ([_],[])
| debugIsOn -> pprPanic "reportNoInstance" (ppr wanted)
res -> Right (mk_overlap_msg wanted res)
where
ASSERT( not (null unifiers) )
parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))),
- ptext (sLit "To pick the first instance above, use -fallow-incoherent-instances"),
+ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
ptext (sLit "when compiling the other instance declarations")])]
where
ispecs = [ispec | (ispec, _) <- matches]
show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
+addTopAmbigErrs :: [Inst] -> TcRn ()
addTopAmbigErrs dicts
-- Divide into groups that share a common set of ambiguous tyvars
= ifErrsM (return ()) $ -- Only report ambiguity if no other errors happened
= 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"
+ then ptext (sLit "or use -XNoMonomorphismRestriction")
+ else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
-- if it is not already set!
+warnDefault :: [(Inst, Class, Var)] -> Type -> TcM ()
warnDefault ups default_ty = do
warn_flag <- doptM Opt_WarnTypeDefaults
addInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg)
quotes (ppr default_ty),
pprDictsInFull tidy_dicts]
+reduceDepthErr :: Int -> [Inst] -> SDoc
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 :: [Inst] -> SDoc
pprStack stack = vcat (map pprInstInFull stack)
\end{code}
projects / ghc-hetmet.git / blobdiff