Type checking for type synonym families

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

diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index 30dfc7c..67f2945 100644 (file)
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -271,7 +271,7 @@ tcDefMeth origin clas tyvars binds_in sig_fn prag_fn sel_id
     
         -- Check the context
        { dict_binds <- tcSimplifyCheck
-                               (ptext SLIT("class") <+> ppr clas)
+                               loc
                                tyvars
                                [this_dict]
                                insts_needed
@@ -362,18 +362,18 @@ tcMethodBind inst_tyvars inst_theta avail_insts sig_fn prag_fn
 
     let
        [(_, Just sig, local_meth_id)] = mono_bind_infos
+       loc = sig_loc sig
     in
 
     addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id))       $
-    newDictBndrs (sig_loc sig) (sig_theta sig)         `thenM` \ meth_dicts ->
+    newDictBndrs loc (sig_theta sig)           `thenM` \ meth_dicts ->
     let
        meth_tvs   = sig_tvs sig
        all_tyvars = meth_tvs ++ inst_tyvars
        all_insts  = avail_insts ++ meth_dicts
     in
     tcSimplifyCheck
-        (ptext SLIT("class or instance method") <+> quotes (ppr sel_id))
-        all_tyvars all_insts meth_lie          `thenM` \ lie_binds ->
+        loc all_tyvars all_insts meth_lie      `thenM` \ lie_binds ->
 
     checkSigTyVars all_tyvars                  `thenM_`
 
@@ -425,7 +425,7 @@ mkMethId origin clas sel_id inst_tys
        rho_ty       = ASSERT( length tyvars == length inst_tys )
                       substTyWith tyvars inst_tys rho
        (preds,tau)  = tcSplitPhiTy rho_ty
-        first_pred   = head preds
+        first_pred   = ASSERT( not (null preds)) head preds
     in
        -- The first predicate should be of form (C a b)
        -- where C is the class in question
@@ -452,8 +452,7 @@ mkMethId origin clas sel_id inst_tys
        getSrcSpanM                     `thenM` \ loc ->
        let 
            real_tau = mkPhiTy (tail preds) tau
-           meth_id  = mkUserLocal (getOccName sel_id) uniq real_tau 
-                       (srcSpanStart loc) --TODO
+           meth_id  = mkUserLocal (getOccName sel_id) uniq real_tau loc
        in
        returnM (Nothing, meth_id)
 
@@ -529,7 +528,7 @@ mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
          -- case we require that the instance decl is for a single-parameter
          -- type class with type variable arguments:
          --    instance (...) => C (T a b)
-    clas_tyvar    = head (classTyVars clas)
+    clas_tyvar    = ASSERT (not (null (classTyVars clas))) head (classTyVars clas)
     Just tycon   = maybe_tycon
     maybe_tycon   = case inst_tys of 
                        [ty] -> case tcSplitTyConApp_maybe ty of
@@ -537,8 +536,8 @@ mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
                                  other                                           -> Nothing
                        other -> Nothing
 
-isInstDecl (SigOrigin (InstSkol _)) = True
-isInstDecl (SigOrigin (ClsSkol _))  = False
+isInstDecl (SigOrigin InstSkol)    = True
+isInstDecl (SigOrigin (ClsSkol _)) = False
 \end{code}
 
 
@@ -707,7 +706,7 @@ mkGenericInstance clas (hs_ty, binds)
        -- Make the dictionary function.
     getSrcSpanM                                                `thenM` \ span -> 
     getOverlapFlag                                     `thenM` \ overlap_flag -> 
-    newDFunName clas [inst_ty] (srcSpanStart span)     `thenM` \ dfun_name ->
+    newDFunName clas [inst_ty] span                    `thenM` \ dfun_name ->
     let
        inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
        dfun_id    = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
@@ -727,15 +726,15 @@ mkGenericInstance clas (hs_ty, binds)
 tcAddDeclCtxt decl thing_inside
   = addErrCtxt ctxt thing_inside
   where
-     thing = case decl of
-               ClassDecl {}              -> "class"
-               TySynonym {}              -> "type synonym"
-               TyFunction {}             -> "type function signature"
-               TyData {tcdND = NewType}  -> "newtype" ++ maybeSig
-               TyData {tcdND = DataType} -> "data type" ++ maybeSig
+     thing | isClassDecl decl  = "class"
+          | isTypeDecl decl   = "type synonym" ++ maybeInst
+          | isDataDecl decl   = if tcdND decl == NewType 
+                                then "newtype" ++ maybeInst
+                                else "data type" ++ maybeInst
+          | isFamilyDecl decl = "family"
 
-     maybeSig | isKindSigDecl decl = " signature"
-             | otherwise          = ""
+     maybeInst | isFamInstDecl decl = " instance"
+              | otherwise          = ""
 
      ctxt = hsep [ptext SLIT("In the"), text thing, 
                  ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
@@ -767,7 +766,7 @@ badGenericInstance sel_id because
 notSimple inst_tys
   = vcat [ptext SLIT("because the instance type(s)"), 
          nest 2 (ppr inst_tys),
-         ptext SLIT("is not a simple type of form (T a b c)")]
+         ptext SLIT("is not a simple type of form (T a1 ... an)")]
 
 notGeneric tycon
   = vcat [ptext SLIT("because the instance type constructor") <+> quotes (ppr tycon) <+>