X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnTypes.lhs;h=0aa0b4e1c568ec0ed9ee1c1377ea940c340e7307;hb=0da2eb6b04a57947fd2b32da9a648ad5eeeb6596;hp=d7d435ce974d97c2d0df0ad116ef0939b78539c6;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index d7d435c..0aa0b4e 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -21,7 +21,7 @@ module RnTypes (
 	dupFieldErr, patSigErr, checkTupSize
   ) where
 
-import DynFlags		( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts) )
+import DynFlags		( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts, Opt_ScopedTypeVariables ) )
 
 import HsSyn
 import RdrHsSyn		( extractHsRhoRdrTyVars )
@@ -121,17 +121,16 @@ rnHsType doc (HsTyVar tyvar)
   = lookupOccRn tyvar 		`thenM` \ tyvar' ->
     returnM (HsTyVar tyvar')
 
-rnHsType doc (HsOpTy ty1 (L loc op) ty2)
-  = setSrcSpan loc (
-      lookupOccRn op			`thenM` \ op' ->
-      let
-	l_op' = L loc op'
-      in
-      lookupTyFixityRn l_op'		`thenM` \ fix ->
-      rnLHsType doc ty1			`thenM` \ ty1' ->
-      rnLHsType doc ty2			`thenM` \ ty2' -> 
-      mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) (ppr op') fix ty1' ty2'
-   )
+rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2)
+  = setSrcSpan loc $ 
+    do	{ ty_ops_ok <- doptM Opt_ScopedTypeVariables	-- Badly named option
+	; checkErr ty_ops_ok (opTyErr op ty)
+	; op' <- lookupOccRn op
+	; let l_op' = L loc op'
+	; fix <- lookupTyFixityRn l_op'
+	; ty1' <- rnLHsType doc ty1
+	; ty2' <- rnLHsType doc ty2
+	; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) (ppr op') fix ty1' ty2' }
 
 rnHsType doc (HsParTy ty)
   = rnLHsType doc ty 	        `thenM` \ ty' ->
@@ -416,7 +415,14 @@ checkPrecMatch True op (MatchGroup ms _)
       = checkPrec op (unLoc p1) False	`thenM_`
         checkPrec op (unLoc p2) True
 
-    check _ = panic "checkPrecMatch"
+    check _ = return ()	
+	-- This can happen.  Consider
+	--	a `op` True = ...
+	--	op          = ...
+	-- The infix flag comes from the first binding of the group
+	-- but the second eqn has no args (an error, but not discovered
+	-- until the type checker).  So we don't want to crash on the
+	-- second eqn.
 
 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
   = lookupFixityRn op		`thenM` \  op_fix@(Fixity op_prec  op_dir) ->
@@ -528,7 +534,6 @@ rnPatsAndThen ctxt pats thing_inside
     bindLocatedLocalsFV doc_pat bndrs	$ \ new_bndrs ->
     rnLPats pats			`thenM` \ (pats', pat_fvs) ->
     thing_inside pats'			`thenM` \ (res, res_fvs) ->
-
     let
 	unused_binders = filter (not . (`elemNameSet` res_fvs)) new_bndrs
     in
@@ -745,12 +750,14 @@ checkTupSize tup_size
 
 forAllWarn doc ty (L loc tyvar)
   = ifOptM Opt_WarnUnusedMatches 	$
-    setSrcSpan loc $
-    addWarn (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
-		   nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
+    addWarnAt loc (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
+		 	nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 		   $$
-		   doc
-                )
+		   doc)
+
+opTyErr op ty 
+  = hang (ptext SLIT("Illegal operator") <+> quotes (ppr op) <+> ptext SLIT("in type") <+> quotes (ppr ty))
+	 2 (parens (ptext SLIT("Use -fscoped-type-variables to allow operators in types")))
 
 bogusCharError c
   = ptext SLIT("character literal out of range: '\\") <> char c  <> char '\''