[project @ 2006-01-06 16:30:17 by simonmar]

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

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 6fdc327..04fbafb 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -9,7 +9,7 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
 #include "HsVersions.h"
 
 import HsSyn
-import TcBinds         ( tcSpecSigs )
+import TcBinds         ( mkPragFun, tcPrags, badBootDeclErr )
 import TcClassDcl      ( tcMethodBind, mkMethodBind, badMethodErr, 
                          tcClassDecl2, getGenericInstances )
 import TcRnMonad       
@@ -22,8 +22,7 @@ import Inst           ( tcInstClassOp, newDicts, instToId, showLIE,
                          getOverlapFlag, tcExtendLocalInstEnv )
 import InstEnv         ( mkLocalInstance, instanceDFunId )
 import TcDeriv         ( tcDeriving )
-import TcEnv           ( tcExtendGlobalValEnv, tcExtendTyVarEnv,
-                         InstInfo(..), InstBindings(..), 
+import TcEnv           ( InstInfo(..), InstBindings(..), 
                          newDFunName, tcExtendIdEnv
                        )
 import TcHsType                ( kcHsSigType, tcHsKindedType )
@@ -36,13 +35,12 @@ import Var          ( Id, idName, idType )
 import MkId            ( mkDictFunId, rUNTIME_ERROR_ID )
 import FunDeps         ( checkInstFDs )
 import Name            ( Name, getSrcLoc )
-import NameSet         ( unitNameSet, emptyNameSet )
-import UnicodeUtil     ( stringToUtf8 )
 import Maybe           ( catMaybes )
 import SrcLoc          ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
 import ListSetOps      ( minusList )
 import Outputable
 import Bag
+import BasicTypes      ( Activation( AlwaysActive ), InlineSpec(..) )
 import FastString
 \end{code}
 
@@ -135,7 +133,7 @@ tcInstDecls1        -- Deal with both source-code and imported instance decls
    -> TcM (TcGblEnv,           -- The full inst env
           [InstInfo],          -- Source-code instance decls to process; 
                                -- contains all dfuns for this module
-          [HsBindGroup Name])  -- Supporting bindings for derived instances
+          HsValBinds Name)     -- Supporting bindings for derived instances
 
 tcInstDecls1 tycl_decls inst_decls
   = checkNoErrs $
@@ -208,6 +206,11 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags))
     let dfun  = mkDictFunId dfun_name tyvars theta clas inst_tys
        ispec = mkLocalInstance dfun overlap_flag
     in
+
+    tcIsHsBoot                                         `thenM` \ is_boot ->
+    checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
+           badBootDeclErr                              `thenM_`
+
     returnM (Just (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags }))
   where
     msg  = parens (ptext SLIT("the instance types do not agree with the functional dependencies of the class"))
@@ -222,7 +225,7 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags))
 
 \begin{code}
 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo] 
-            -> TcM (TcLclEnv, LHsBinds Id)
+            -> TcM (LHsBinds Id, TcLclEnv)
 -- (a) From each class declaration, 
 --     generate any default-method bindings
 -- (b) From each instance decl
@@ -238,9 +241,10 @@ tcInstDecls2 tycl_decls inst_decls
        ; inst_binds_s <- mappM tcInstDecl2 inst_decls
 
                -- Done
-       ; tcl_env <- getLclEnv
-       ; returnM (tcl_env, unionManyBags dm_binds_s    `unionBags`
-                           unionManyBags inst_binds_s) }
+       ; let binds = unionManyBags dm_binds_s `unionBags` 
+                     unionManyBags inst_binds_s
+       ; tcl_env <- getLclEnv          -- Default method Ids in here
+       ; returnM (binds, tcl_env) }
 \end{code}
 
 ======= New documentation starts here (Sept 92)         ==============
@@ -364,27 +368,21 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds })
        -- of the inst_tyavars' with something in the envt
     checkSigTyVars inst_tyvars'        `thenM_`
 
-       -- Deal with 'SPECIALISE instance' pragmas by making them
-       -- look like SPECIALISE pragmas for the dfun
+       -- Deal with 'SPECIALISE instance' pragmas 
     let
-       uprags = case binds of
-                      VanillaInst _ uprags -> uprags
-                      other                -> []
-       spec_prags = [ L loc (SpecSig (L loc (idName dfun_id)) ty)
-                    | L loc (SpecInstSig ty) <- uprags ]
+       specs = case binds of
+                 VanillaInst _ prags -> filter isSpecInstLSig prags
+                 other               -> []
     in
-    tcExtendGlobalValEnv [dfun_id] (
-       tcExtendTyVarEnv inst_tyvars'   $
-       tcSpecSigs spec_prags
-    )                                  `thenM` \ prag_binds ->
-
+    tcPrags dfun_id specs                      `thenM` \ prags -> 
+    
        -- Create the result bindings
     let
         dict_constr   = classDataCon clas
        scs_and_meths = map instToId sc_dicts ++ meth_ids
        this_dict_id  = instToId this_dict
-       inlines       | null dfun_arg_dicts = emptyNameSet
-                     | otherwise           = unitNameSet (idName dfun_id)
+       inline_prag | null dfun_arg_dicts = []
+                   | otherwise = [InlinePrag (Inline AlwaysActive True)]
                -- Always inline the dfun; this is an experimental decision
                -- because it makes a big performance difference sometimes.
                -- Often it means we can do the method selection, and then
@@ -406,7 +404,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds })
                -- Hardly beautiful, but only three extra lines.
            nlHsApp (noLoc $ TyApp (nlHsVar rUNTIME_ERROR_ID) 
                                   [idType this_dict_id])
-                 (nlHsLit (HsStringPrim (mkFastString (stringToUtf8 msg))))
+                 (nlHsLit (HsStringPrim (mkFastString msg)))
 
          | otherwise   -- The common case
          = mkHsConApp dict_constr inst_tys' (map HsVar scs_and_meths)
@@ -426,12 +424,12 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds })
        main_bind = noLoc $ AbsBinds
                            inst_tyvars'
                            (map instToId dfun_arg_dicts)
-                           [(inst_tyvars', dfun_id, this_dict_id)] 
-                           inlines all_binds
+                           [(inst_tyvars', dfun_id, this_dict_id, 
+                                           inline_prag ++ prags)] 
+                           all_binds
     in
     showLIE (text "instance")          `thenM_`
-    returnM (unitBag main_bind `unionBags` 
-            prag_binds )
+    returnM (unitBag main_bind)
 
 
 tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' 
@@ -479,8 +477,9 @@ tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
        -- The trouble is that the 'meth_inst' for op, which is 'available', also
        -- looks like 'op at Int'.  But they are not the same.
     let
+       prag_fn        = mkPragFun uprags
        all_insts      = avail_insts ++ catMaybes meth_insts
-       tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts uprags 
+       tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts prag_fn
        meth_ids       = [meth_id | (_,meth_id,_) <- meth_infos]
     in