Adding pushing of hpc translation status through hi files.

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

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index b0ca87a..d314e1e 100644 (file)
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -147,9 +147,8 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                -- (they recover, so that we get more than one error each
                -- round) 
 
-               -- (1) Do class instance declarations and instances of indexed
-               --     types 
-       ; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
+               -- (1) Do class and family instance declarations
+       ; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls }
        ; local_info_tycons <- mappM tcLocalInstDecl1  inst_decls
        ; idx_tycons        <- mappM tcIdxTyInstDeclTL idxty_decls
 
@@ -180,7 +179,10 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                -- (4) Compute instances from "deriving" clauses; 
                -- This stuff computes a context for the derived instance
                -- decl, so it needs to know about all the instances possible
-       ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls deriv_decls
+                -- NB: class instance declarations can contain derivings as
+                --     part of associated data type declarations
+       ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls inst_decls 
+                                                      deriv_decls
        ; addInsts deriv_inst_info   $ do {
 
        ; gbl_env <- getGblEnv
@@ -193,7 +195,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
     -- !!!TODO: Need to perform this check for the TyThing of type functions,
     --         too.
     tcIdxTyInstDeclTL ldecl@(L loc decl) =
-      do { tything <- tcIdxTyInstDecl ldecl
+      do { tything <- tcFamInstDecl ldecl
         ; setSrcSpan loc $
             when (isAssocFamily tything) $
               addErr $ assocInClassErr (tcdName decl)
@@ -240,14 +242,10 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
        ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
                  badBootDeclErr
 
-       -- Typecheck the instance type itself.  We can't use 
-       -- tcHsSigType, because it's not a valid user type.
-       ; kinded_ty <- kcHsSigType poly_ty
-       ; poly_ty'  <- tcHsKindedType kinded_ty
-       ; let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
+       ; (tyvars, theta, tau) <- tcHsInstHead poly_ty
        
        -- Next, process any associated types.
-       ; idx_tycons <- mappM tcIdxTyInstDecl ats
+       ; idx_tycons <- mappM tcFamInstDecl ats
 
        -- Now, check the validity of the instance.
        ; (clas, inst_tys) <- checkValidInstHead tau
@@ -257,7 +255,7 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
 
        -- Finally, construct the Core representation of the instance.
        -- (This no longer includes the associated types.)
-       ; dfun_name <- newDFunName clas inst_tys (srcSpanStart loc)
+       ; dfun_name <- newDFunName clas inst_tys loc
        ; overlap_flag <- getOverlapFlag
        ; let dfun           = mkDictFunId dfun_name tyvars theta clas inst_tys
              ispec          = mkLocalInstance dfun overlap_flag
@@ -278,11 +276,11 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
     checkValidAndMissingATs clas inst_tys ats
       = do { -- Issue a warning for each class AT that is not defined in this
             -- instance.
-          ; let classDefATs = listToNameSet . map tyConName . classATs $ clas
-                 definedATs  = listToNameSet . map (tcdName.unLoc.fst)  $ ats
-                omitted     = classDefATs `minusNameSet` definedATs
+          ; let class_ats   = map tyConName (classATs clas)
+                 defined_ats = listToNameSet . map (tcdName.unLoc.fst)  $ ats
+                omitted     = filterOut (`elemNameSet` defined_ats) class_ats
           ; warn <- doptM Opt_WarnMissingMethods
-          ; mapM_ (warnTc warn . omittedATWarn) (nameSetToList omitted)
+          ; mapM_ (warnTc warn . omittedATWarn) omitted
           
             -- Ensure that all AT indexes that correspond to class parameters
             -- coincide with the types in the instance head.  All remaining
@@ -587,10 +585,11 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
        dfun_id    = instanceDFunId ispec
        rigid_info = InstSkol
        inst_ty    = idType dfun_id
+       loc        = srcLocSpan (getSrcLoc dfun_id)
     in
         -- Prime error recovery
     recoverM (returnM emptyLHsBinds)           $
-    setSrcSpan (srcLocSpan (getSrcLoc dfun_id))        $
+    setSrcSpan loc                             $
     addErrCtxt (instDeclCtxt2 (idType dfun_id))        $
 
        -- Instantiate the instance decl with skolem constants 
@@ -611,7 +610,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
     newDictBndrs sc_loc sc_theta'                      `thenM` \ sc_dicts ->
     getInstLoc origin                                  `thenM` \ inst_loc -> 
     newDictBndrs inst_loc dfun_theta'                  `thenM` \ dfun_arg_dicts ->
-    newDictBndr inst_loc (mkClassPred clas inst_tys')  `thenM` \ this_dict ->
+    newDictBndr inst_loc (mkClassPred clas inst_tys')   `thenM` \ this_dict ->
                -- Default-method Ids may be mentioned in synthesised RHSs,
                -- but they'll already be in the environment.
 
@@ -643,7 +642,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
        scs_and_meths = map instToId sc_dicts ++ meth_ids
        this_dict_id  = instToId this_dict
        inline_prag | null dfun_arg_dicts = []
-                   | otherwise = [InlinePrag (Inline AlwaysActive True)]
+                   | otherwise = [L loc (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