Remove checkTopTypeD

[ghc-hetmet.git] / compiler / parser / RdrHsSyn.lhs

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index b0cf2cf..b66c759 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -35,10 +35,10 @@ module RdrHsSyn (
        checkPrecP,           -- Int -> P Int
        checkContext,         -- HsType -> P HsContext
        checkPred,            -- HsType -> P HsPred
-       checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
+       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])
-       checkTopTyClD,        -- LTyClDecl RdrName -> P (HsDecl RdrName)
+       checkKindSigs,        -- [LTyClDecl RdrName] -> P ()
        checkInstType,        -- HsType -> P HsType
        checkPattern,         -- HsExp -> P HsPat
        checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
@@ -213,7 +213,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, [], [])
@@ -401,7 +401,8 @@ checkTyVars tparms nonVarsOk =
 
 -- Check whether the type arguments in a type synonym head are simply
 -- variables.  If not, we have a type equation of a type function and return
--- all patterns.
+-- all patterns.  If yes, we return 'Nothing' as the third component to
+-- indicate a vanilla type synonym.
 --
 checkSynHdr :: LHsType RdrName 
            -> Bool                             -- non-variables admitted?
@@ -409,7 +410,7 @@ checkSynHdr :: LHsType RdrName
                  [LHsTyVarBndr RdrName],       -- parameters
                  Maybe [LHsType RdrName])      -- type patterns
 checkSynHdr ty nonVarsOk = 
-  do { (_, tc, tvs, Just tparms) <- checkTyClHdr (noLoc []) ty
+  do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
      ; typats <- checkTyVars tparms nonVarsOk
      ; return (tc, tvs, typats) }
 
@@ -420,8 +421,7 @@ checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
   -> P (LHsContext RdrName,         -- the type context
         Located RdrName,            -- the head symbol (type or class name)
        [LHsTyVarBndr RdrName],      -- free variables of the non-context part
-       Maybe [LHsType RdrName])     -- parameters of head symbol; wrapped into
-                                    -- 'Maybe' for 'mkTyData'
+       [LHsType RdrName])           -- parameters of head symbol
 -- The header of a type or class decl should look like
 --     (C a, D b) => T a b
 -- or  T a b
@@ -433,11 +433,11 @@ checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
 -- result.  Eg, for
 --      T Int [a]
 -- we return
---      ('()', 'T', ['a'], Just ['Int', '[a]'])
+--      ('()', 'T', ['a'], ['Int', '[a]'])
 checkTyClHdr (L l cxt) ty
   = do (tc, tvs, parms) <- gol ty []
        mapM_ chk_pred cxt
-       return (L l cxt, tc, tvs, Just parms)
+       return (L l cxt, tc, tvs, parms)
   where
     gol (L l ty) acc = go l ty acc
 
@@ -506,16 +506,16 @@ extractTyVars tvs = collects [] tvs
                            tvs' <- collects tvs ts
                            collect tvs' t
 
--- Wrap a toplevel type or class declaration into 'TyClDecl' after ensuring
--- that all type parameters are variables only (which is in contrast to
--- associated type declarations).
+-- Check that associated type declarations of a class are all kind signatures.
 --
-checkTopTyClD :: LTyClDecl RdrName -> P (HsDecl RdrName)
-checkTopTyClD (L _ d@TyData {tcdTyPats = Just typats}) = 
-  do
-    checkTyVars typats False
-    return $ TyClD d {tcdTyPats = Nothing}
-checkTopTyClD (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)