projects
/
ghc-hetmet.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
422028f
)
Fix warnings in TcSimplify
author
Ian Lynagh
<igloo@earth.li>
Fri, 6 Jun 2008 20:24:35 +0000
(20:24 +0000)
committer
Ian Lynagh
<igloo@earth.li>
Fri, 6 Jun 2008 20:24:35 +0000
(20:24 +0000)
compiler/typecheck/TcSimplify.lhs
patch
|
blob
|
history
diff --git
a/compiler/typecheck/TcSimplify.lhs
b/compiler/typecheck/TcSimplify.lhs
index
d2f8242
..
fbd676f
100644
(file)
--- a/
compiler/typecheck/TcSimplify.lhs
+++ b/
compiler/typecheck/TcSimplify.lhs
@@
-6,13
+6,6
@@
TcSimplify
\begin{code}
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,
module TcSimplify (
tcSimplifyInfer, tcSimplifyInferCheck,
tcSimplifyCheck, tcSimplifyRestricted,
@@
-42,7
+35,6
@@
import TcMType
import TcIface
import TcTyFuns
import DsUtils -- Big-tuple functions
import TcIface
import TcTyFuns
import DsUtils -- Big-tuple functions
-import TypeRep
import Var
import Name
import NameSet
import Var
import Name
import NameSet
@@
-56,14
+48,12
@@
import ErrUtils
import BasicTypes
import VarSet
import VarEnv
import BasicTypes
import VarSet
import VarEnv
-import Module
import FiniteMap
import Bag
import Outputable
import Maybes
import ListSetOps
import Util
import FiniteMap
import Bag
import Outputable
import Maybes
import ListSetOps
import Util
-import UniqSet
import SrcLoc
import DynFlags
import FastString
import SrcLoc
import DynFlags
import FastString
@@
-891,7
+881,9
@@
isFreeWhenChecking qtvs ips inst
&& isFreeWrtIPs ips inst
-}
&& isFreeWrtIPs ips inst
-}
+isFreeWrtTyVars :: VarSet -> Inst -> Bool
isFreeWrtTyVars qtvs inst = tyVarsOfInst inst `disjointVarSet` qtvs
isFreeWrtTyVars qtvs inst = tyVarsOfInst inst `disjointVarSet` qtvs
+isFreeWrtIPs :: NameSet -> Inst -> Bool
isFreeWrtIPs ips inst = not (any (`elemNameSet` ips) (ipNamesOfInst inst))
\end{code}
isFreeWrtIPs ips inst = not (any (`elemNameSet` ips) (ipNamesOfInst inst))
\end{code}
@@
-1005,8
+997,7
@@
makeImplicationBind loc all_tvs
tci_given = (eq_givens ++ dict_givens),
tci_wanted = irreds, tci_loc = loc }
; let -- only create binder for dict_irreds
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
lpat = mkBigLHsPatTup (map (L span . VarPat) dict_irred_ids)
rhs = L span (mkHsWrap co (HsVar (instToId implic_inst)))
dict_irred_ids = map instToId dict_irreds
lpat = mkBigLHsPatTup (map (L span . VarPat) dict_irred_ids)
rhs = L span (mkHsWrap co (HsVar (instToId implic_inst)))
@@
-1032,7
+1023,7
@@
tryHardCheckLoop doc wanteds
; return (irreds,binds)
}
where
; return (irreds,binds)
}
where
- try_me inst = ReduceMe AddSCs
+ try_me _ = ReduceMe AddSCs
-- Here's the try-hard bit
-----------------------------------------------------------
-- Here's the try-hard bit
-----------------------------------------------------------
@@
-1232,7
+1223,7
@@
tcSimplifySuperClasses loc givens sc_wanteds
; return binds1 }
where
env = mkRedEnv (pprInstLoc loc) try_me givens
; 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}
-- Like tryHardCheckLoop, but with NoSCs
\end{code}
@@
-1365,7
+1356,7
@@
tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
-- BUT do no improvement! See Plan D above
-- HOWEVER, some unification may take place, if we instantiate
-- a method Inst with an equality constraint
-- 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
; (_imp, _binds, constrained_dicts, elim_skolems)
<- reduceContext env wanteds'
; elim_skolems
@@
-1775,7
+1766,7
@@
reduceContext env wanteds
given_dicts0
-- 5. Build the Avail mapping from "given_dicts"
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
}
{ init_state <- foldlM addGiven emptyAvails given_dicts
; return init_state
}
@@
-1890,8
+1881,11
@@
unifyEqns eqns
mapM_ (unif_pr tenv) pairs
unif_pr tenv (ty1,ty2) = unifyType (substTy tenv ty1) (substTy tenv ty2)
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' }
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' }
@@
-1921,9
+1915,10
@@
reduceList env@(RedEnv {red_stack = (n,stk)}) wanteds state
; go ws state' }
-- Base case: we're done!
; 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
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 { traceTc (text "reduce: found " <+> ppr wanted)
; return avails
}
@@
-1963,7
+1958,7
@@
reduce env wanted avails
= do { res <- lookupSimpleInst wanted
; case res of
GenInst [] rhs -> addWanted AddSCs avails wanted rhs []
= 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}
\end{code}
@@
-2054,7
+2049,7
@@
contributing clauses.
\begin{code}
---------------------------------------------
reduceInst :: RedEnv -> Avails -> Inst -> TcM (Avails, LookupInstResult)
\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}
= do { result <- lookupSimpleInst other_inst
; return (avails, result) }
\end{code}
@@
-2125,7
+2120,7
@@
reduceImplication env
tci_tyvars = tvs,
tci_given = extra_givens, tci_wanted = wanteds })
= do { -- Solve the sub-problem
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,
env' = env { red_givens = extra_givens ++ red_givens env
, red_doc = sep [ptext (sLit "reduceImplication for")
<+> ppr name,
@@
-2200,6
+2195,7
@@
reduceImplication env
simpler_implic_insts)
}
}
simpler_implic_insts)
}
}
+reduceImplication _ i = pprPanic "reduceImplication" (ppr i)
\end{code}
Note [Always inline implication constraints]
\end{code}
Note [Always inline implication constraints]
@@
-2297,6
+2293,7
@@
data AvailHow
instance Outputable Avails where
ppr = pprAvails
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 $
pprAvails (Avails imp avails)
= vcat [ ptext (sLit "Avails") <> (if imp then ptext (sLit "[improved]") else empty)
, nest 2 $ braces $
@@
-2341,11
+2338,8
@@
extendAvails avails@(Avails imp env) inst avail
availsInsts :: Avails -> [Inst]
availsInsts (Avails _ avails) = keysFM avails
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.
\end{code}
Extracting the bindings from a bunch of Avails.
@@
-2373,7
+2367,7
@@
extractResults (Avails _ avails) wanteds
-> DoneEnv -- Has an entry for each inst in the above three sets
-> [Inst] -- Wanted
-> TcM (TcDictBinds, [Inst], [Inst])
-> 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)
= return (binds, bound_dicts, irreds)
go binds bound_dicts irreds done (w:ws)
@@
-2455,7
+2449,7
@@
addAvailAndSCs want_scs avails inst avail
-- 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
-- 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
find_all :: IdSet -> Inst -> IdSet
find_all so_far kid
@@
-2495,7
+2489,7
@@
addSCs is_loop avails dict
is_given :: Inst -> Bool
is_given sc_dict = case findAvail avails sc_dict of
Just (Given _) -> True -- Given is cheaper than superclass selection
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).
-- From the a set of insts obtain all equalities that (transitively) occur in
-- superclass contexts of class constraints (aka the ancestor equalities).
@@
-2559,6
+2553,7
@@
tcSimplifyInteractive wanteds
-- The TcLclEnv should be valid here, solely to improve
-- error message generation for the monomorphism restriction
-- 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
tc_simplify_top doc interactive wanteds
= do { dflags <- getDOpts
; wanteds <- zonkInsts wanteds
@@
-2568,7
+2563,7
@@
tc_simplify_top doc interactive wanteds
; (irreds1, binds1) <- tryHardCheckLoop doc1 wanteds
-- ; (irreds1, binds1) <- gentleInferLoop doc1 wanteds
; traceTc (text "tc_simplify_top 1: " <+> ppr irreds1)
; (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
; traceTc (text "tc_simplify_top 2: " <+> ppr irreds2)
-- Use the defaulting rules to do extra unification
@@
-2736,7
+2731,7
@@
getDefaultTys extended_deflts ovl_strings
opt_deflt ovl_strings string_ty) } } }
where
opt_deflt True ty = [ty]
opt_deflt ovl_strings string_ty) } } }
where
opt_deflt True ty = [ty]
- opt_deflt False ty = []
+ opt_deflt False _ = []
\end{code}
Note [Default unitTy]
\end{code}
Note [Default unitTy]
@@
-2853,7
+2848,7
@@
groupErrs :: ([Inst] -> TcM ()) -- Deal with one group
-- Group together insts with the same origin
-- We want to report them together in error messages
-- 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)
= return ()
groupErrs report_err (inst:insts)
= do { do_one (inst:friends)
@@
-2873,7
+2868,7
@@
addInstLoc :: [Inst] -> Message -> Message
addInstLoc insts msg = msg $$ nest 2 (pprInstArising (head insts))
addTopIPErrs :: [Name] -> [Inst] -> TcM ()
addInstLoc insts msg = msg $$ nest 2 (pprInstArising (head insts))
addTopIPErrs :: [Name] -> [Inst] -> TcM ()
-addTopIPErrs bndrs []
+addTopIPErrs _ []
= return ()
addTopIPErrs bndrs ips
= do { dflags <- getDOpts
= return ()
addTopIPErrs bndrs ips
= do { dflags <- getDOpts
@@
-2916,6
+2911,7
@@
reportNoInstances
reportNoInstances tidy_env mb_what insts
= groupErrs (report_no_instances tidy_env mb_what) insts
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
report_no_instances tidy_env mb_what insts
= do { inst_envs <- tcGetInstEnvs
; let (implics, insts1) = partition isImplicInst insts
@@
-2947,7
+2943,7
@@
report_no_instances tidy_env mb_what 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
-- 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
| debugIsOn -> pprPanic "reportNoInstance" (ppr wanted)
res -> Right (mk_overlap_msg wanted res)
where
@@
-3009,6
+3005,7
@@
report_no_instances tidy_env mb_what insts
show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
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
addTopAmbigErrs dicts
-- Divide into groups that share a common set of ambiguous tyvars
= ifErrsM (return ()) $ -- Only report ambiguity if no other errors happened
@@
-3068,6
+3065,7
@@
monomorphism_fix dflags
else empty] -- Only suggest adding "-fno-monomorphism-restriction"
-- if it is not already set!
else empty] -- Only suggest adding "-fno-monomorphism-restriction"
-- 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)
warnDefault ups default_ty = do
warn_flag <- doptM Opt_WarnTypeDefaults
addInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg)
@@
-3080,10
+3078,12
@@
warnDefault ups default_ty = do
quotes (ppr default_ty),
pprDictsInFull tidy_dicts]
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)]
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}
pprStack stack = vcat (map pprInstInFull stack)
\end{code}