[project @ 2002-09-09 12:55:52 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcClassDcl.lhs

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 79c834d..079cdb3 100644 (file)
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -11,13 +11,13 @@ module TcClassDcl ( tcClassDecl1, tcClassDecls2,
 #include "HsVersions.h"
 
 import HsSyn           ( TyClDecl(..), Sig(..), MonoBinds(..),
-                         HsExpr(..), HsLit(..), 
+                         HsExpr(..), HsLit(..), InPat(WildPatIn),
                          mkSimpleMatch, andMonoBinds, andMonoBindList, 
-                         isClassOpSig, isPragSig,
+                         isClassOpSig, isPragSig, 
                          getClassDeclSysNames, placeHolderType
                        )
 import BasicTypes      ( RecFlag(..), StrictnessMark(..) )
-import RnHsSyn         ( RenamedTyClDecl, 
+import RnHsSyn         ( RenamedTyClDecl, RenamedSig,
                          RenamedClassOpSig, RenamedMonoBinds,
                          maybeGenericMatch
                        )
@@ -35,7 +35,7 @@ import TcSimplify     ( tcSimplifyCheck )
 import TcUnify         ( checkSigTyVars, sigCtxt )
 import TcMType         ( tcInstTyVars )
 import TcType          ( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar, 
-                         mkTyVarTys, mkPredTys, mkClassPred, 
+                         mkTyVarTys, mkPredTys, mkClassPred, tcSplitSigmaTy, tcSplitFunTys,
                          tcIsTyVarTy, tcSplitTyConApp_maybe
                        )
 import TcMonad
@@ -46,11 +46,11 @@ import Class                ( classTyVars, classBigSig, classTyCon,
 import TyCon           ( tyConGenInfo )
 import MkId            ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
 import DataCon         ( mkDataCon )
-import Id              ( Id, idType, idName, setIdLocalExported )
+import Id              ( Id, idType, idName, setIdLocalExported, setInlinePragma )
 import Module          ( Module )
 import Name            ( Name, NamedThing(..) )
 import NameEnv         ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv )
-import NameSet         ( emptyNameSet )
+import NameSet         ( emptyNameSet, unitNameSet )
 import Outputable
 import Var             ( TyVar )
 import CmdLineOpts
@@ -385,7 +385,7 @@ tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name)
 
     mkMethodBind origin clas inst_tys binds_in op_item `thenTc` \ (dm_inst, meth_info) ->
     tcMethodBind xtve clas_tyvars theta 
-                [this_dict] meth_info                  `thenTc` \ (defm_bind, insts_needed) ->
+                [this_dict] prags meth_info            `thenTc` \ (defm_bind, insts_needed) ->
     
     tcAddErrCtxt (defltMethCtxt clas) $
     
@@ -436,10 +436,11 @@ tcMethodBind
        -> TcThetaType          -- Available theta; it's just used for the error message
        -> [Inst]               -- Available from context, used to simplify constraints 
                                --      from the method body
+       -> [RenamedSig]         -- Pragmas (e.g. inline pragmas)
        -> (Id, TcSigInfo, RenamedMonoBinds)    -- Details of this method
        -> TcM (TcMonoBinds, LIE)
 
-tcMethodBind xtve inst_tyvars inst_theta avail_insts
+tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
             (sel_id, meth_sig, meth_bind)
   =  
        -- Check the bindings; first adding inst_tyvars to the envt
@@ -473,11 +474,22 @@ tcMethodBind xtve inst_tyvars inst_theta avail_insts
      checkSigTyVars all_tyvars                         `thenTc` \ all_tyvars' ->
 
      let
+               -- Attach inline pragmas as appropriate
+       (final_meth_id, inlines) 
+          | (InlineSig inl _ phase _ : _) <- filter is_inline prags
+          = (meth_id `setInlinePragma` phase,
+             if inl then unitNameSet (idName meth_id) else emptyNameSet)
+          | otherwise
+          = (meth_id, emptyNameSet)
+
+       is_inline (InlineSig _ name _ _) = name == idName sel_id
+       is_inline other                  = False
+
        meth_tvs'      = take (length meth_tvs) all_tyvars'
        poly_meth_bind = AbsBinds meth_tvs'
                                  (map instToId meth_dicts)
-                                 [(meth_tvs', meth_id, local_meth_id)]
-                                 emptyNameSet  -- Inlines?
+                                 [(meth_tvs', final_meth_id, local_meth_id)]
+                                 inlines
                                  (lie_binds `andMonoBinds` meth_bind)
      in
      returnTc (poly_meth_bind, lie)
@@ -528,10 +540,30 @@ mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
           (omittedMethodWarn sel_id)           `thenNF_Tc_`
     returnTc error_rhs
   where
-    error_rhs = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID)) 
-                     (HsLit (HsStringPrim (mkFastString (stringToUtf8 error_msg))))
+    error_rhs  = HsLam (mkSimpleMatch wild_pats simple_rhs placeHolderType loc)
+    simple_rhs = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID)) 
+                      (HsLit (HsStringPrim (mkFastString (stringToUtf8 error_msg))))
     error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
 
+       -- When the type is of form t1 -> t2 -> t3
+       -- make a default method like (\ _ _ -> noMethBind "blah")
+       -- rather than simply        (noMethBind "blah")
+       -- Reason: if t1 or t2 are higher-ranked types we get n
+       --         silly ambiguity messages.
+       -- Example:     f :: (forall a. Eq a => a -> a) -> Int
+       --              f = error "urk"
+       -- Here, tcSub tries to force (error "urk") to have the right type,
+       -- thus:        f = \(x::forall a. Eq a => a->a) -> error "urk" (x t)
+       -- where 't' is fresh ty var.  This leads directly to "ambiguous t".
+       -- 
+       -- NB: technically this changes the meaning of the default-default
+       --     method slightly, because `seq` can see the lambdas.  Oh well.
+    (_,_,tau1)    = tcSplitSigmaTy (idType sel_id)
+    (_,_,tau2)    = tcSplitSigmaTy tau1
+       -- Need two splits because the  selector can have a type like
+       --      forall a. Foo a => forall b. Eq b => ...
+    (arg_tys, _) = tcSplitFunTys tau2
+    wild_pats   = [WildPatIn | ty <- arg_tys]
 
 mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth 
   =    -- A generic default method