[project @ 2003-07-16 13:33:55 by simonmar]

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

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 639b772..820ed74 100644 (file)
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -16,7 +16,7 @@ import HsSyn          ( TyClDecl(..), Sig(..), MonoBinds(..),
                          isClassOpSig, isPragSig, 
                          placeHolderType
                        )
-import BasicTypes      ( RecFlag(..), StrictnessMark(..) )
+import BasicTypes      ( RecFlag(..) )
 import RnHsSyn         ( RenamedTyClDecl, RenamedSig,
                          RenamedClassOpSig, RenamedMonoBinds,
                          maybeGenericMatch
@@ -26,13 +26,13 @@ import TcHsSyn              ( TcMonoBinds )
 
 import Inst            ( Inst, InstOrigin(..), instToId, newDicts, newMethod )
 import TcEnv           ( TyThingDetails(..), 
-                         tcLookupClass, tcExtendTyVarEnv2, 
-                         tcExtendTyVarEnv
+                         tcLookupClass, tcExtendLocalValEnv2,
+                         tcExtendTyVarEnv2, tcExtendTyVarEnv
                        )
 import TcTyDecls       ( tcMkDataCon )
-import TcBinds         ( tcMonoBinds )
+import TcBinds         ( tcMonoBinds, tcSpecSigs )
 import TcMonoType      ( TcSigInfo(..), tcHsType, tcHsTheta, mkTcSig )
-import TcSimplify      ( tcSimplifyCheck )
+import TcSimplify      ( tcSimplifyCheck, bindInstsOfLocalFuns )
 import TcUnify         ( checkSigTyVars, sigCtxt )
 import TcMType         ( tcInstTyVars )
 import TcType          ( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar, 
@@ -48,12 +48,11 @@ import Class                ( classTyVars, classBigSig, classTyCon,
 import TyCon           ( tyConGenInfo )
 import Subst           ( substTyWith )
 import MkId            ( mkDictSelId, mkDefaultMethodId )
-import Id              ( Id, idType, idName, mkUserLocal, setIdLocalExported, setInlinePragma )
+import Id              ( Id, idType, idName, mkUserLocal, setInlinePragma )
 import Name            ( Name, NamedThing(..) )
 import NameEnv         ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv )
 import NameSet         ( emptyNameSet, unitNameSet )
-import OccName         ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc, 
-                         mkSuperDictSelOcc, reportIfUnused )
+import OccName         ( mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc, reportIfUnused )
 import Outputable
 import Var             ( TyVar )
 import CmdLineOpts
@@ -122,7 +121,7 @@ tcClassDecl1 (ClassDecl {tcdCtxt = context, tcdName = class_name,
     in
     tcExtendTyVarEnv tyvars                            $ 
 
-    checkDefaultBinds clas op_names def_methods          `thenM` \ mb_dm_env ->
+    checkDefaultBinds clas op_names def_methods                `thenM` \ mb_dm_env ->
        
        -- CHECK THE CONTEXT
        -- The renamer has already checked that the context mentions
@@ -373,14 +372,7 @@ tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnM (EmptyMonoBinds,
 tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name)
   = tcInstTyVars ClsTv tyvars          `thenM` \ (clas_tyvars, inst_tys, _) ->
     let
-       dm_ty = idType sel_id   -- Same as dict selector!
-          -- The default method's type should really come from the
-          -- iface file, since it could be usage-generalised, but this
-          -- requires altering the mess of knots in TcModule and I'm
-          -- too scared to do that.  Instead, I have disabled generalisation
-          -- of types of default methods (and dict funs) by annotating them
-          -- TyGenNever (in MkId).  Ugh!  KSW 1999-09.
-
+       dm_ty       = idType sel_id     -- Same as dict selector!
         theta       = [mkClassPred clas inst_tys]
        local_dm_id = mkDefaultMethodId dm_name dm_ty
        xtve        = tyvars `zip` clas_tyvars
@@ -453,12 +445,13 @@ tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
             (sel_id, meth_id, meth_bind)
   =    -- Check the bindings; first adding inst_tyvars to the envt
        -- so that we don't quantify over them in nested places
-    mkTcSig meth_id                            `thenM` \ meth_sig ->
+     mkTcSig meth_id                           `thenM` \ meth_sig ->
 
      tcExtendTyVarEnv2 xtve (
-       addErrCtxt (methodCtxt sel_id)          $
-       getLIE (tcMonoBinds meth_bind [meth_sig] NonRecursive)
-     )                                         `thenM` \ ((meth_bind, _, _), meth_lie) ->
+       addErrCtxt (methodCtxt sel_id)                  $
+       getLIE                                          $
+       tcMonoBinds meth_bind [meth_sig] NonRecursive
+     )                                                 `thenM` \ ((meth_bind,_), meth_lie) ->
 
        -- Now do context reduction.   We simplify wrt both the local tyvars
        -- and the ones of the class/instance decl, so that there is
@@ -484,25 +477,42 @@ tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
      checkSigTyVars all_tyvars                 `thenM` \ all_tyvars' ->
 
      let
+       sel_name = idName sel_id
+       inline_prags  = [ (is_inl, phase)
+                       | InlineSig is_inl name phase _ <- prags, 
+                         name == sel_name ]
+       spec_prags = [ prag 
+                    | prag@(SpecSig name _ _) <- prags, 
+                      name == sel_name]
+       
                -- Attach inline pragmas as appropriate
        (final_meth_id, inlines) 
-          | (InlineSig inl _ phase _ : _) <- filter is_inline prags
+          | ((is_inline, phase) : _) <- inline_prags
           = (meth_id `setInlinePragma` phase,
-             if inl then unitNameSet (idName meth_id) else emptyNameSet)
+             if is_inline 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', final_meth_id, local_meth_id)]
                                  inlines
                                  (lie_binds `andMonoBinds` meth_bind)
+
      in
-     returnM poly_meth_bind
+       -- Deal with specialisation pragmas
+       -- The sel_name is what appears in the pragma
+     tcExtendLocalValEnv2 [(sel_name, final_meth_id)] (
+       getLIE (tcSpecSigs spec_prags)                  `thenM` \ (spec_binds1, prag_lie) ->
+     
+            -- The prag_lie for a SPECIALISE pragma will mention the function itself, 
+            -- so we have to simplify them away right now lest they float outwards!
+       bindInstsOfLocalFuns prag_lie [final_meth_id]   `thenM` \ spec_binds2 ->
+       returnM (spec_binds1 `andMonoBinds` spec_binds2)
+     )                                                 `thenM` \ spec_binds ->
+
+     returnM (poly_meth_bind `andMonoBinds` spec_binds)
 
 
 mkMethodBind :: InstOrigin
@@ -536,7 +546,6 @@ mkMethId :: InstOrigin -> Class
         -> TcM (Maybe Inst, Id)
             
 -- mkMethId instantiates the selector Id at the specified types
--- THe 
 mkMethId origin clas sel_id inst_tys
   = let
        (tyvars,rho) = tcSplitForAllTys (idType sel_id)