X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=b9ff78917e93d3a158c4a9428a0ba70969f67f5e;hb=f8ec4ec53ba9377254af4c0c0d3787bbe1e27be3;hp=b4b0b73478ae3844d3338aae6964232dcbc0b150;hpb=66f73ee4d4130b98d35ec26bba073b2197724011;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index b4b0b73..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,
@@ -2252,17 +2265,7 @@ disambiguate interactive dflags insts
 	;     return () }
   | otherwise
   = do 	{  	-- Figure out what default types to use
-	  mb_defaults <- getDefaultTys
-	; default_tys <- case mb_defaults of
-			   Just tys -> return tys
-			   Nothing  -> 	-- No use-supplied default;
-					-- use [Integer, Double]
-				do { integer_ty <- tcMetaTy integerTyConName
-				   ; checkWiredInTyCon doubleTyCon
-				   ; string_ty <- tcMetaTy stringTyConName
-				   ; if ovl_strings 	-- Add String if -foverloaded-strings
-					then return [integer_ty,doubleTy,string_ty] 
-					else return [integer_ty,doubleTy] }
+	; 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  }
@@ -2325,8 +2328,43 @@ disambigGroup default_tys dicts
 		-- 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
@@ -2539,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
@@ -2612,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")
@@ -2620,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")