[project @ 2004-10-04 09:35:08 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 2be946e..e4bc357 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -49,7 +49,7 @@ import Var            ( TyVar, idType, idName )
 import VarSet          ( elemVarSet )
 import Name            ( Name )
 import Outputable
-import Util            ( zipLazy, isSingleton, notNull )
+import Util            ( zipLazy, isSingleton, notNull, sortLe )
 import List            ( partition )
 import SrcLoc          ( Located(..), unLoc, getLoc )
 import ListSetOps      ( equivClasses )
@@ -108,10 +108,10 @@ The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
 @TyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
 
 \begin{code}
-tcTyAndClassDecls :: [LTyClDecl Name]
+tcTyAndClassDecls :: [Name] -> [LTyClDecl Name]
                   -> TcM TcGblEnv      -- Input env extended by types and classes 
                                        -- and their implicit Ids,DataCons
-tcTyAndClassDecls decls
+tcTyAndClassDecls boot_names decls
   = do {       -- First check for cyclic type synonysm or classes
                -- See notes with checkCycleErrs
          checkCycleErrs decls
@@ -133,7 +133,7 @@ tcTyAndClassDecls decls
                { (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls
 
                ; let { calc_vrcs = calcTyConArgVrcs (rec_syn_tycons ++ rec_alg_tyclss)
-                     ; calc_rec  = calcRecFlags     rec_alg_tyclss
+                     ; calc_rec  = calcRecFlags boot_names rec_alg_tyclss
                      ; tc_decl   = addLocM (tcTyClDecl calc_vrcs calc_rec) }
                        -- Type-check the type synonyms, and extend the envt
                ; syn_tycons <- tcSynDecls calc_vrcs kc_syn_decls
@@ -322,8 +322,14 @@ kcTyClDeclBody decl thing_inside
     do         { tc_ty_thing <- tcLookupLocated (tcdLName decl)
        ; let tc_kind = case tc_ty_thing of { AThing k -> k }
        ; unifyKind tc_kind (foldr (mkArrowKind . kindedTyVarKind) 
-                                  liftedTypeKind kinded_tvs)
+                                  (result_kind decl)
+                                  kinded_tvs)
        ; thing_inside kinded_tvs }
+  where
+    result_kind (TyData { tcdKindSig = Just kind }) = kind
+    result_kind other                             = liftedTypeKind
+       -- On GADT-style declarations we allow a kind signature
+       --      data T :: *->* where { ... }
 
 kindedTyVarKind (L _ (KindedTyVar _ k)) = k
 \end{code}
@@ -677,19 +683,26 @@ badGenericMethodType op op_ty
                ptext SLIT("You can only use type variables, arrows, and tuples")])
 
 recSynErr syn_decls
-  = setSrcSpan (getLoc (head syn_decls)) $
+  = setSrcSpan (getLoc (head sorted_decls)) $
     addErr (sep [ptext SLIT("Cycle in type synonym declarations:"),
-                nest 2 (vcat (map ppr_decl syn_decls))])
+                nest 2 (vcat (map ppr_decl sorted_decls))])
   where
+    sorted_decls = sortLocated syn_decls
     ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl
 
 recClsErr cls_decls
-  = setSrcSpan (getLoc (head cls_decls)) $
+  = setSrcSpan (getLoc (head sorted_decls)) $
     addErr (sep [ptext SLIT("Cycle in class declarations (via superclasses):"),
-                nest 2 (vcat (map ppr_decl cls_decls))])
+                nest 2 (vcat (map ppr_decl sorted_decls))])
   where
+    sorted_decls = sortLocated cls_decls
     ppr_decl (L loc decl) = ppr loc <> colon <+> ppr (decl { tcdSigs = [] })
 
+sortLocated :: [Located a] -> [Located a]
+sortLocated things = sortLe le things
+  where
+    le (L l1 _) (L l2 _) = l1 <= l2
+
 exRecConErr name
   = ptext SLIT("Can't combine named fields with locally-quantified type variables or context")
     $$