Use OPTIONS rather than OPTIONS_GHC for pragmas

[ghc-hetmet.git] / compiler / typecheck / TcBinds.lhs
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs

index 351b6d8..a18c9ac 100644 (file)
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -5,6 +5,13 @@
  \section[TcBinds]{TcBinds}
  
  \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/CodingStyle#Warnings
+-- for details
+
  module TcBinds ( tcLocalBinds, tcTopBinds, 
                  tcHsBootSigs, tcMonoBinds, 
                  TcPragFun, tcSpecPrag, tcPrags, mkPragFun, 
@@ -30,6 +37,7 @@ import TcPat
  import TcMType
  import TcType
  import {- Kind parts of -} Type
+import Coercion
  import VarEnv
  import TysPrim
  import Id
@@ -241,7 +249,7 @@ tc_haskell98 top_lvl sig_fn prag_fn rec_flag binds thing_inside
  bindLocalInsts :: TopLevelFlag -> TcM ([LHsBinds TcId], [TcId], a) -> TcM ([LHsBinds TcId], a)
  bindLocalInsts top_lvl thing_inside
    | isTopLevel top_lvl = do { (binds, ids, thing) <- thing_inside; return (binds, thing) }
-       -- For the top level don't bother will all this bindInstsOfLocalFuns stuff. 
+       -- For the top level don't bother with all this bindInstsOfLocalFuns stuff. 
         -- All the top level things are rec'd together anyway, so it's fine to
         -- leave them to the tcSimplifyTop, and quite a bit faster too
  
@@ -511,7 +519,7 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
         -- e.g.         f = \(x::forall a. a->a) -> <body>
         --      We want to infer a higher-rank type for f
      setSrcSpan b_loc   $
-    do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name matches)
+    do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches)
  
                 -- Check for an unboxed tuple type
                 --      f = (# True, False #)
@@ -546,7 +554,7 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
                         | (name, tv) <- sig_scoped tc_sig `zip` sig_tvs tc_sig ]
  
         ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs    $
-                              tcMatchesFun mono_name matches mono_ty
+                              tcMatchesFun mono_name inf matches mono_ty
  
         ; let fun_bind' = FunBind { fun_id = L nm_loc mono_id, 
                                     fun_infix = inf, fun_matches = matches',
@@ -653,8 +661,8 @@ tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind)
  -------------------
  tcRhs :: TcMonoBind -> TcM (HsBind TcId)
  tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches)
-  = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) matches 
-                                           (idType mono_id)
+  = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) inf 
+                                           matches (idType mono_id)
         ; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches',
                             bind_fvs = placeHolderNames, fun_co_fn = co_fn,
                             fun_tick = Nothing }) }
@@ -769,7 +777,17 @@ unifyCtxts (sig1 : sigs)   -- Argument is always non-empty
      unify_ctxt sig@(TcSigInfo { sig_theta = theta })
         = setSrcSpan (instLocSpan (sig_loc sig))        $
           addErrCtxt (sigContextsCtxt sig1 sig)         $
-         unifyTheta theta1 theta
+         do { cois <- unifyTheta theta1 theta
+            ; -- Check whether all coercions are identity coercions
+              -- That can happen if we have, say
+              --         f :: C [a]   => ...
+              --         g :: C (F a) => ...
+              -- where F is a type function and (F a ~ [a])
+              -- Then unification might succeed with a coercion.  But it's much
+              -- much simpler to require that such signatures have identical contexts
+              checkTc (all isIdentityCoercion cois)
+                      (ptext SLIT("Mutually dependent functions have syntactically distinct contexts"))
+            }
  
  checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
  checkSigsTyVars qtvs sigs