X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=b9ff78917e93d3a158c4a9428a0ba70969f67f5e;hb=923ee9d360ed15331ac6faf8a6b4aca334fc0cee;hp=7311ae0be82c2bca14d14a707bb84016aaa87302;hpb=d4b95ea994e850f2c85e418b5625874fd25b0ebf;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 7311ae0..b9ff789 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -889,7 +889,7 @@ makeImplicationBind loc all_tvs reft
  | otherwise			-- Otherwise we must generate a binding
  = do	{ uniq <- newUnique 
 	; span <- getSrcSpanM
-	; let name = mkInternalName uniq (mkVarOcc "ic") (srcSpanStart span)
+	; let name = mkInternalName uniq (mkVarOcc "ic") span
 	      implic_inst = ImplicInst { tci_name = name, tci_reft = reft,
 					 tci_tyvars = all_tvs, 
 					 tci_given = givens,
@@ -1202,9 +1202,22 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
 	; gbl_tvs' <- tcGetGlobalTyVars
 	; constrained_dicts' <- mappM zonkInst constrained_dicts
 
-	; let constrained_tvs' = tyVarsOfInsts constrained_dicts'
-	      qtvs = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs')
-			 `minusVarSet` constrained_tvs'
+	; let qtvs1 = tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs'
+				-- As in tcSimplifyInfer
+
+		-- Do not quantify over constrained type variables:
+		-- this is the monomorphism restriction
+	      constrained_tvs' = tyVarsOfInsts constrained_dicts'
+	      qtvs = qtvs1 `minusVarSet` constrained_tvs'
+	      pp_bndrs = pprWithCommas (quotes . ppr) bndrs
+
+	-- Warn in the mono
+	; warn_mono <- doptM Opt_WarnMonomorphism
+	; warnTc (warn_mono && (constrained_tvs' `intersectsVarSet` qtvs1))
+		 (vcat[ ptext SLIT("the Monomorphism Restriction applies to the binding")
+				<> plural bndrs <+> ptext SLIT("for") <+> pp_bndrs,
+			ptext SLIT("Consider giving a type signature for") <+> pp_bndrs])
+
 	; traceTc (text "tcSimplifyRestricted" <+> vcat [
 		pprInsts wanteds, pprInsts constrained_dicts',
 		ppr _binds,
@@ -2320,8 +2333,8 @@ disambigGroup default_tys dicts
 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
+	; case mb_defaults of {
+	   Just tys -> return tys ;	-- User-supplied defaults
 	   Nothing  -> do
 
 	-- No use-supplied default
@@ -2334,7 +2347,7 @@ getDefaultTys extended_deflts ovl_strings
 			++
 		  [integer_ty,doubleTy]
 			++
-		  opt_deflt ovl_strings string_ty) }}
+		  opt_deflt ovl_strings string_ty) } } }
   where
     opt_deflt True  ty = [ty]
     opt_deflt False ty = []
@@ -2564,7 +2577,7 @@ report_no_instances tidy_env mb_what insts
 	    		         quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))),
 			      ptext SLIT("Use -fallow-incoherent-instances to use the first choice above")])]
       where
-    	ispecs = [ispec | (_, ispec) <- matches]
+    	ispecs = [ispec | (ispec, _) <- matches]
 
     mk_no_inst_err insts
       | null insts = empty
@@ -2637,6 +2650,10 @@ mkMonomorphismMsg tidy_env inst_tvs
   = findGlobals (mkVarSet inst_tvs) tidy_env	`thenM` \ (tidy_env, docs) ->
     returnM (tidy_env, mk_msg 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")
@@ -2645,6 +2662,11 @@ mkMonomorphismMsg tidy_env inst_tvs
 			nest 2 (vcat docs),
 			monomorphism_fix
 		       ]
+
+isRuntimeUnk :: TcTyVar -> Bool
+isRuntimeUnk x | SkolemTv RuntimeUnkSkol <- tcTyVarDetails x = True
+               | otherwise = False
+
 monomorphism_fix :: SDoc
 monomorphism_fix = ptext SLIT("Probable fix:") <+> 
 		   (ptext SLIT("give these definition(s) an explicit type signature")