Use OPTIONS rather than OPTIONS_GHC for pragmas
[ghc-hetmet.git] / compiler / typecheck / TcBinds.lhs
index 9c176d0..a18c9ac 100644 (file)
@@ -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
@@ -162,9 +170,9 @@ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
 
                -- Extend the envt right away with all 
                -- the Ids declared with type signatures
-       ; gla_exts     <- doptM Opt_GlasgowExts
+       ; poly_rec <- doptM Opt_RelaxedPolyRec
        ; (binds', thing) <- tcExtendIdEnv poly_ids $
-                            tc_val_binds gla_exts top_lvl sig_fn prag_fn 
+                            tc_val_binds poly_rec top_lvl sig_fn prag_fn 
                                          binds thing_inside
 
        ; return (ValBindsOut binds' sigs, thing) }
@@ -176,14 +184,14 @@ tc_val_binds :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun
 -- Typecheck a whole lot of value bindings,
 -- one strongly-connected component at a time
 
-tc_val_binds gla_exts top_lvl sig_fn prag_fn [] thing_inside
+tc_val_binds poly_rec top_lvl sig_fn prag_fn [] thing_inside
   = do { thing <- thing_inside
        ; return ([], thing) }
 
-tc_val_binds gla_exts top_lvl sig_fn prag_fn (group : groups) thing_inside
+tc_val_binds poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside
   = do { (group', (groups', thing))
-               <- tc_group gla_exts top_lvl sig_fn prag_fn group $ 
-                  tc_val_binds gla_exts top_lvl sig_fn prag_fn groups thing_inside
+               <- tc_group poly_rec top_lvl sig_fn prag_fn group $ 
+                  tc_val_binds poly_rec top_lvl sig_fn prag_fn groups thing_inside
        ; return (group' ++ groups', thing) }
 
 ------------------------
@@ -195,15 +203,15 @@ tc_group :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun
 -- We get a list of groups back, because there may 
 -- be specialisations etc as well
 
-tc_group gla_exts top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
+tc_group poly_rec top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
        -- A single non-recursive binding
        -- We want to keep non-recursive things non-recursive
         -- so that we desugar unlifted bindings correctly
  =  do { (binds, thing) <- tc_haskell98 top_lvl sig_fn prag_fn NonRecursive binds thing_inside
        ; return ([(NonRecursive, b) | b <- binds], thing) }
 
-tc_group gla_exts top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
-  | not gla_exts       -- Recursive group, normal Haskell 98 route
+tc_group poly_rec top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
+  | not poly_rec       -- Recursive group, normal Haskell 98 route
   = do { (binds1, thing) <- tc_haskell98 top_lvl sig_fn prag_fn Recursive binds thing_inside
        ; return ([(Recursive, unionManyBags binds1)], thing) }
 
@@ -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
 
@@ -337,7 +345,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
 
        -- BUILD THE POLYMORPHIC RESULT IDs
   ; let dict_ids = map instToId dicts
-  ; exports <- mapM (mkExport prag_fn tyvars_to_gen (map idType dict_ids))
+  ; exports <- mapM (mkExport top_lvl prag_fn tyvars_to_gen (map idType dict_ids))
                    mono_bind_infos
 
   ; let        poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
@@ -352,8 +360,9 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
 
 
 --------------
-mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo
-        -> TcM ([TyVar], Id, Id, [Prag])
+mkExport :: TopLevelFlag -> TcPragFun -> [TyVar] -> [TcType]
+        -> MonoBindInfo
+        -> TcM ([TyVar], Id, Id, [LPrag])
 -- mkExport generates exports with 
 --     zonked type variables, 
 --     zonked poly_ids
@@ -365,8 +374,10 @@ mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo
 
 -- Pre-condition: the inferred_tvs are already zonked
 
-mkExport prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id)
-  = do { (tvs, poly_id) <- mk_poly_id mb_sig
+mkExport top_lvl prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id)
+  = do { warn_missing_sigs <- doptM Opt_WarnMissingSigs
+       ; let warn = isTopLevel top_lvl && warn_missing_sigs
+       ; (tvs, poly_id) <- mk_poly_id warn mb_sig
 
        ; poly_id' <- zonkId poly_id
        ; prags <- tcPrags poly_id' (prag_fn poly_name)
@@ -376,9 +387,10 @@ mkExport prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id)
   where
     poly_ty = mkForAllTys inferred_tvs (mkFunTys dict_tys (idType mono_id))
 
-    mk_poly_id Nothing    = return (inferred_tvs, mkLocalId poly_name poly_ty)
-    mk_poly_id (Just sig) = do { tvs <- mapM zonk_tv (sig_tvs sig)
-                              ; return (tvs,  sig_id sig) }
+    mk_poly_id warn Nothing    = do { missingSigWarn warn poly_name poly_ty
+                                   ; return (inferred_tvs, mkLocalId poly_name poly_ty) }
+    mk_poly_id warn (Just sig) = do { tvs <- mapM zonk_tv (sig_tvs sig)
+                                   ; return (tvs,  sig_id sig) }
 
     zonk_tv tv = do { ty <- zonkTcTyVar tv; return (tcGetTyVar "mkExport" ty) }
 
@@ -393,12 +405,11 @@ mkPragFun sigs = \n -> lookupNameEnv env n `orElse` []
          env = foldl add emptyNameEnv prs
          add env (n,p) = extendNameEnv_Acc (:) singleton env n p
 
-tcPrags :: Id -> [LSig Name] -> TcM [Prag]
-tcPrags poly_id prags = mapM tc_prag prags
+tcPrags :: Id -> [LSig Name] -> TcM [LPrag]
+tcPrags poly_id prags = mapM (wrapLocM tc_prag) prags
   where
-    tc_prag (L loc prag) = setSrcSpan loc $ 
-                          addErrCtxt (pragSigCtxt prag) $ 
-                          tcPrag poly_id prag
+    tc_prag prag = addErrCtxt (pragSigCtxt prag) $ 
+                  tcPrag poly_id prag
 
 pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag)
 
@@ -508,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 #)
@@ -543,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',
@@ -650,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 }) }
@@ -766,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 
@@ -1145,4 +1166,13 @@ restrictedBindCtxtErr binder_names
 
 genCtxt binder_names
   = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names
+
+missingSigWarn False name ty = return ()
+missingSigWarn True  name ty
+  = do         { env0 <- tcInitTidyEnv
+       ; let (env1, tidy_ty) = tidyOpenType env0 ty
+       ; addWarnTcM (env1, mk_msg tidy_ty) }
+  where
+    mk_msg ty = vcat [ptext SLIT("Definition but no type signature for") <+> quotes (ppr name),
+                     sep [ptext SLIT("Inferred type:") <+> ppr name <+> dcolon <+> ppr ty]]
 \end{code}