X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=687ffd2bbcf7d1da95a968210e38f2ac6a338cf3;hb=e3dd39bf230380f02d73efc287226117bb2eb47f;hp=28f8fcbaf99801432ad0d6759d3f741e0f014753;hpb=f39ff24bc78da5ba09db8864ecbd7d1055b332db;p=ghc-hetmet.git

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 28f8fcb..687ffd2 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -42,6 +42,7 @@ module RdrHsSyn (
 	checkInstType,	      -- HsType -> P HsType
         checkDerivDecl,       -- LDerivDecl RdrName -> P (LDerivDecl RdrName)
 	checkPattern,	      -- HsExp -> P HsPat
+	bang_RDR,
 	checkPatterns,	      -- SrcLoc -> [HsExp] -> P [HsPat]
 	checkDo,	      -- [Stmt] -> P [Stmt]
 	checkMDo,	      -- [Stmt] -> P [Stmt]
@@ -96,8 +97,9 @@ extractHsRhoRdrTyVars ctxt ty
 
 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
 
-extract_pred (HsClassP cls tys) acc	= foldr extract_lty acc tys
-extract_pred (HsIParam n ty) acc	= extract_lty ty acc
+extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys
+extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
+extract_pred (HsIParam n ty   ) acc = extract_lty ty acc
 
 extract_lty (L loc ty) acc 
   = case ty of
@@ -309,7 +311,7 @@ add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs, hs_docs = docs})
 		addl (gp { hs_tyclds = L l d : ts, 
                            hs_fixds = fsigs ++ fs,
                            hs_docs = add_doc decl docs}) ds
-	| isIdxTyDecl d = 
+	| isFamInstDecl d = 
 	        addl (gp { hs_tyclds = L l d : ts }) ds
 	| otherwise =
 		addl (gp { hs_tyclds = L l d : ts, 
@@ -405,6 +407,15 @@ checkInstType (L l t)
 	ty ->   do dict_ty <- checkDictTy (L l ty)
 	      	   return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 
+checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
+checkDictTy (L spn ty) = check ty []
+  where
+  check (HsTyVar t) args | not (isRdrTyVar t) 
+  	= return (L spn (HsPredTy (HsClassP t args)))
+  check (HsAppTy l r) args = check (unLoc l) (r:args)
+  check (HsParTy t)   args = check (unLoc t) args
+  check _ _ = parseError spn "Malformed instance header"
+
 -- Check whether the given list of type parameters are all type variables
 -- (possibly with a kind signature).  If the second argument is `False',
 -- only type variables are allowed and we raise an error on encountering a
@@ -476,10 +487,12 @@ checkTyClHdr (L l cxt) ty
     go l other	         acc    = 
       parseError l "Malformed head of type or class declaration"
 
-	-- The predicates in a type or class decl must all
-	-- be HsClassPs.  They need not all be type variables,
-	-- even in Haskell 98.  E.g. class (Monad m, Monad (t m)) => MonadT t m
-    chk_pred (L l (HsClassP _ args)) = return ()
+	-- The predicates in a type or class decl must be class predicates or 
+	-- equational constraints.  They need not all have variable-only
+	-- arguments, even in Haskell 98.  
+	-- E.g. class (Monad m, Monad (t m)) => MonadT t m
+    chk_pred (L l (HsClassP _ _)) = return ()
+    chk_pred (L l (HsEqualP _ _)) = return ()
     chk_pred (L l _)
        = parseError l "Malformed context in type or class declaration"
 
@@ -535,7 +548,7 @@ checkKindSigs :: [LTyClDecl RdrName] -> P ()
 checkKindSigs = mapM_ check
   where
     check (L l tydecl) 
-      | isKindSigDecl tydecl
+      | isFamilyDecl tydecl
         || isSynDecl tydecl  = return ()
       | otherwise	     = 
 	parseError l "Type declaration in a class must be a kind signature or synonym default"
@@ -570,22 +583,16 @@ checkPred (L spn ty)
   where
     checkl (L l ty) args = check l ty args
 
+    check _loc (HsPredTy pred@(HsEqualP _ _)) 
+                                       args | null args
+					    = return $ L spn pred
     check _loc (HsTyVar t)             args | not (isRdrTyVar t) 
 		 		  	    = return (L spn (HsClassP t args))
     check _loc (HsAppTy l r)           args = checkl l (r:args)
     check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
     check _loc (HsParTy t)  	       args = checkl t args
-    check loc _                        _    = parseError loc  "malformed class assertion"
-
-checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
-checkDictTy (L spn ty) = check ty []
-  where
-  check (HsTyVar t) args | not (isRdrTyVar t) 
-  	= return (L spn (HsPredTy (HsClassP t args)))
-  check (HsAppTy l r) args = check (unLoc l) (r:args)
-  check (HsParTy t)   args = check (unLoc t) args
-  check _ _ = parseError spn "Malformed context in instance header"
-
+    check loc _                        _    = parseError loc  
+					        "malformed class assertion"
 
 ---------------------------------------------------------------------------
 -- Checking stand-alone deriving declarations
@@ -757,7 +764,7 @@ makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
 makeFunBind fn is_infix ms 
   = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
-	      fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames }
+	      fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
 
 checkPatBind lhs (L _ grhss)
   = do	{ lhs <- checkPattern lhs