X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=abd04a6402c2d2675a2e494015d2a10824854404;hb=e8fa04cf0d656c4a2ff737278b8cea9fce3b5a2b;hp=03fa83af1b98639e81e89953685aa655b652fe4e;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 03fa83a..abd04a6 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -121,13 +121,13 @@ tcLocalBinds (HsValBinds binds) thing_inside
 
 tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
   = do  { (given_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds
+        ; let ip_tvs = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet given_ips
 
         -- If the binding binds ?x = E, we  must now 
         -- discharge any ?x constraints in expr_lie
         ; (ev_binds, result) <- checkConstraints (IPSkol ips) 
-                                  emptyVarSet [] -- No skolem tyvars and hence 
-                                                 -- no need for envt tyvars
-                                  given_ips $
+                                  ip_tvs  -- See Note [Implicit parameter untouchables]
+                                  [] given_ips $
                                 thing_inside
 
         ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) }
@@ -142,8 +142,20 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
             ; ip_id <- newIP ip ty
             ; expr' <- tcMonoExpr expr ty
             ; return (ip_id, (IPBind (IPName ip_id) expr')) }
+\end{code}
 
-------------------------
+Note [Implicit parameter untouchables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We add the type variables in the types of the implicit parameters
+as untouchables, not so much because we really must not unify them,
+but rather because we otherwise end up with constraints like this
+    Num alpha, Implic { wanted = alpha ~ Int }
+The constraint solver solves alpha~Int by unification, but then
+doesn't float that solved constraint out (it's not an unsolved 
+wanted.  Result disaster: the (Num alpha) is again solved, this
+time by defaulting.  No no no.
+
+\begin{code}
 tcValBinds :: TopLevelFlag 
            -> HsValBinds Name -> TcM thing
            -> TcM (HsValBinds TcId, thing) 
@@ -323,16 +335,8 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
         -- They desugar to a case expression in the end
     ; checkStrictBinds top_lvl rec_group bind_list poly_ids
 
-	 -- Warn about missing signatures
-	 -- Do this only when we we have a type to offer
-    ; warn_missing_sigs <- doptM Opt_WarnMissingSigs
-    ; when (isTopLevel top_lvl && warn_missing_sigs) $
-      mapM_ missingSigWarn (filter no_sig poly_ids)
-
     ; return (binds, poly_ids) }
   where
-    no_sig id = isNothing (sig_fn (idName id))
-
     binder_names = collectHsBindListBinders bind_list
     loc = getLoc (head bind_list)
          -- TODO: location a bit awkward, but the mbinds have been
@@ -1070,7 +1074,7 @@ decideGeneralisationPlan dflags top_lvl _bndrs binds sig_fn
   | Just sig <- one_funbind_with_sig binds = if null (sig_tvs sig) && null (sig_theta sig)
                                              then NoGen	      -- Optimise common case
                                              else CheckGen sig
-  | (dopt Opt_MonoLocalBinds dflags 
+  | (xopt Opt_MonoLocalBinds dflags 
       && isNotTopLevel top_lvl)      	   = NoGen
   | otherwise                              = InferGen mono_restriction
 
@@ -1078,10 +1082,10 @@ decideGeneralisationPlan dflags top_lvl _bndrs binds sig_fn
 --  | otherwise            	     	   = NoGen   -- A mixture of function 
 --    				       		     -- and pattern bindings
   where
-    mono_pat_binds = dopt Opt_MonoPatBinds dflags 
+    mono_pat_binds = xopt Opt_MonoPatBinds dflags 
                   && any (is_pat_bind . unLoc) binds
 
-    mono_restriction = dopt Opt_MonomorphismRestriction dflags 
+    mono_restriction = xopt Opt_MonomorphismRestriction dflags 
                     && any (restricted . unLoc) binds
 
     no_sig n = isNothing (sig_fn n)
@@ -1179,35 +1183,4 @@ sigContextsCtxt sig1 sig2
   where
     id1 = sig_id sig1
     id2 = sig_id sig2
-
------------------------------------------------
-{- 
-badStrictSig :: Bool -> TcSigInfo -> SDoc
-badStrictSig unlifted sig
-  = hang (ptext (sLit "Illegal polymorphic signature in") <+> msg)
-       2 (ppr sig)
-  where
-    msg | unlifted  = ptext (sLit "an unlifted binding")
-        | otherwise = ptext (sLit "a bang-pattern binding")
-
-restrictedBindSigErr :: [Name] -> SDoc
-restrictedBindSigErr binder_names
-  = hang (ptext (sLit "Illegal type signature(s)"))
-       2 (vcat [ptext (sLit "in a binding group for") <+> pprBinders binder_names,
-                ptext (sLit "that falls under the monomorphism restriction")])
-
-genCtxt :: [Name] -> SDoc
-genCtxt binder_names
-  = ptext (sLit "When generalising the type(s) for") <+> pprBinders binder_names
--}
-
-missingSigWarn :: TcId -> TcM ()
-missingSigWarn id
-  = do  { env0 <- tcInitTidyEnv
-        ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
-        ; addWarnTcM (env1, mk_msg tidy_ty) }
-  where
-    name = idName id
-    mk_msg ty = vcat [ptext (sLit "Definition but no type signature for") <+> quotes (ppr name),
-                      sep [ptext (sLit "Inferred type:") <+> pprHsVar name <+> dcolon <+> ppr ty]]
 \end{code}