X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=14ccd2765387ed1a6a1eaa079aef65d7f0c8a054;hb=7ab880e6cbce4e095d8316d4289066aa2d50419b;hp=980c7f754a1c79d2738e1b2487c1b47a3da15aa0;hpb=77ede632bfb1f0df2224b392cd0b7ed009baa9d0;p=ghc-hetmet.git

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 980c7f7..14ccd27 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -36,9 +36,9 @@ module RdrHsSyn (
 	checkContext,	      -- HsType -> P HsContext
 	checkPred,	      -- HsType -> P HsPred
 	checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
-	checkTyVars,          -- [LHsType RdrName] -> Bool -> P ()
-	checkSynHdr,	      -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
-	checkTopTypeD,	      -- LTyClDecl RdrName -> P (HsDecl RdrName)
+	checkTyVars,          -- [LHsType RdrName] -> P ()
+	checkSynHdr,	      -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
+	checkKindSigs,	      -- [LTyClDecl RdrName] -> P ()
 	checkInstType,	      -- HsType -> P HsType
 	checkPattern,	      -- HsExp -> P HsPat
 	checkPatterns,	      -- SrcLoc -> [HsExp] -> P [HsPat]
@@ -70,6 +70,7 @@ import FastString
 import Panic
 
 import List		( isSuffixOf, nubBy )
+import Monad		( unless )
 \end{code}
 
 
@@ -213,7 +214,7 @@ cvBindsAndSigs :: OrdList (LHsDecl RdrName)
   -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName])
 -- Input decls contain just value bindings and signatures
 -- and in case of class or instance declarations also
--- associated data or synonym definitions
+-- associated type declarations
 cvBindsAndSigs  fb = go (fromOL fb)
   where
     go [] 		   = (emptyBag, [], [])
@@ -378,25 +379,20 @@ checkInstType (L l t)
 	      	   return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 
 -- Check whether the given list of type parameters are all type variables
--- (possibly with a kind signature).  If the second argument is `False', we
+-- (possibly with a kind signature).  If the second argument is `False',
 -- only type variables are allowed and we raise an error on encountering a
--- non-variable; otherwise, we return the entire list parameters iff at least
--- one is not a variable.
+-- non-variable; otherwise, we allow non-variable arguments and return the
+-- entire list of parameters.
 --
-checkTyVars :: [LHsType RdrName] -> Bool -> P (Maybe [LHsType RdrName])
-checkTyVars tparms nonVarsOk = 
-  do
-    areVars <- mapM chk tparms
-    return $ if and areVars then Nothing else Just tparms
+checkTyVars :: [LHsType RdrName] -> P ()
+checkTyVars tparms = mapM_ chk tparms
   where
 	-- Check that the name space is correct!
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
-	| isRdrTyVar tv    = return True
+	| isRdrTyVar tv    = return ()
     chk (L l (HsTyVar tv))
-        | isRdrTyVar tv    = return True
-    chk (L l other)
-        | nonVarsOk        = return False
-        | otherwise        = 
+        | isRdrTyVar tv    = return ()
+    chk (L l other)        =
 	  parseError l "Type found where type variable expected"
 
 -- Check whether the type arguments in a type synonym head are simply
@@ -405,14 +401,14 @@ checkTyVars tparms nonVarsOk =
 -- indicate a vanilla type synonym.
 --
 checkSynHdr :: LHsType RdrName 
-	    -> Bool                             -- non-variables admitted?
+	    -> Bool                             -- is type instance?
 	    -> P (Located RdrName,		-- head symbol
 	          [LHsTyVarBndr RdrName],	-- parameters
-		  Maybe [LHsType RdrName])	-- type patterns
-checkSynHdr ty nonVarsOk = 
+		  [LHsType RdrName])	        -- type patterns
+checkSynHdr ty isTyInst = 
   do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
-     ; typats <- checkTyVars tparms nonVarsOk
-     ; return (tc, tvs, typats) }
+     ; unless isTyInst $ checkTyVars tparms
+     ; return (tc, tvs, tparms) }
 
 
 -- Well-formedness check and decomposition of type and class heads.
@@ -506,21 +502,16 @@ extractTyVars tvs = collects [] tvs
 			    tvs' <- collects tvs ts
 			    collect tvs' t
 
--- Wrap a toplevel type or data declaration into 'TyClD' and ensure for 
--- data declarations that all type parameters are variables only (which is in
--- contrast to type functions and associated type declarations).
+-- Check that associated type declarations of a class are all kind signatures.
 --
-checkTopTypeD :: LTyClDecl RdrName -> P (HsDecl RdrName)
-checkTopTypeD (L _ d@TyData {tcdTyPats = Just typats}) = 
-  do
-    -- `tcdTyPats' will only be of the form `Just typats' if `typats' contains
-    -- a non-variable pattern.  We call `checkTyPats' instead of raising an
-    -- error straight away, as `checkTyPats' raises the error at the location
-    -- of that non-variable pattern.
-    --
-    checkTyVars typats False
-    panic "checkTopTypeD: check on previous line should fail w/ a parse error"
-checkTopTypeD (L _ d) = return $ TyClD d
+checkKindSigs :: [LTyClDecl RdrName] -> P ()
+checkKindSigs = mapM_ check
+  where
+    check (L l tydecl) 
+      | isKindSigDecl tydecl
+        || isSynDecl tydecl  = return ()
+      | otherwise	     = 
+	parseError l "Type declaration in a class must be a kind signature or synonym default"
 
 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
 checkContext (L l t)