From abb7803606acd590db525eb93351ea9899d93f72 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Mon, 16 Mar 2009 17:47:06 +0000
Subject: [PATCH] Fix Trac #3095, and make RdrHsSyn warning-clean

---
 compiler/parser/RdrHsSyn.lhs |   46 ++++++++++++++++++++++--------------------
 1 file changed, 24 insertions(+), 22 deletions(-)

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index ccf9756..bccf27f 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -4,13 +4,6 @@
 Functions over HsSyn specialised to RdrName.
 
 \begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 module RdrHsSyn (
 	extractHsTyRdrTyVars, 
 	extractHsRhoRdrTyVars, extractGenericPatTyVars,
@@ -42,7 +35,8 @@ 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], [LHsType RdrName])
+	checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName
+                              -- -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
 	checkTyVars,          -- [LHsType RdrName] -> P ()
 	checkSynHdr,	      -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
 	checkKindSigs,	      -- [LTyClDecl RdrName] -> P ()
@@ -80,6 +74,8 @@ import FastString
 
 import List		( isSuffixOf, nubBy )
 import Monad		( unless )
+
+#include "HsVersions.h"
 \end{code}
 
 
@@ -225,8 +221,8 @@ cvTopDecls decls = go (fromOL decls)
 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
 cvBindGroup binding
   = case cvBindsAndSigs binding of
-      (mbs, sigs, [], _) ->                 -- list of type decls *always* empty
-        ValBindsIn mbs sigs
+      (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
+      	    	  	         ValBindsIn mbs sigs
 
 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
   -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
@@ -237,14 +233,15 @@ cvBindsAndSigs  fb = go (fromOL fb)
   where
     go [] 		   = (emptyBag, [], [], [])
     go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
-			    where (bs, ss, ts, docs) = go ds
+			   where (bs, ss, ts, docs) = go ds
     go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
-			    where (b', ds')    = getMonoBind (L l b) ds
-				  (bs, ss, ts, docs) = go ds'
+			   where (b', ds')    = getMonoBind (L l b) ds
+				 (bs, ss, ts, docs) = go ds'
     go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
-			    where (bs, ss, ts, docs) = go ds
-    go (L l (DocD d) : ds)     =  (bs, ss, ts, (L l d) : docs)
-			    where (bs, ss, ts, docs) = go ds
+			   where (bs, ss, ts, docs) = go ds
+    go (L l (DocD d) : ds) =  (bs, ss, ts, (L l d) : docs)
+			   where (bs, ss, ts, docs) = go ds
+    go (L _ d : _)        = pprPanic "cvBindsAndSigs" (ppr d)
 
 -----------------------------------------------------------------------------
 -- Group function bindings into equation groups
@@ -285,6 +282,7 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
 getMonoBind bind binds = (bind, binds)
 
 has_args :: [LMatch RdrName] -> Bool
+has_args [] 	    	     	      = panic "RdrHsSyn:has_args"
 has_args ((L _ (Match args _ _)) : _) = not (null args)
 	-- Don't group together FunBinds if they have
 	-- no arguments.  This is necessary now that variable bindings
@@ -359,9 +357,11 @@ add gp l (DocD d) ds
 
 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
+add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"
 
 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
-add_sig  s (ValBindsIn bs sigs) = ValBindsIn bs	              (s:sigs) 
+add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) 
+add_sig _ (ValBindsOut {})     = panic "RdrHsSyn:add_sig"
 \end{code}
 
 %************************************************************************
@@ -541,13 +541,14 @@ extractTyVars tvs = collects tvs []
     collect (L _ (HsNumTy _         )) = return
     collect (L l (HsPredTy _        )) = 
       const $ parseError l "Predicate not allowed as type parameter"
-    collect (L l (HsKindSig (L _ (HsTyVar tv)) k))
-	| isRdrTyVar tv                = 
-	  return . (L l (KindedTyVar tv k) :)
-	| otherwise                    =
-	  const $ parseError l "Kind signature only allowed for type variables"
+    collect (L l (HsKindSig (L _ ty) k))
+	| HsTyVar tv <- ty, isRdrTyVar tv
+	= return . (L l (KindedTyVar tv k) :)
+	| otherwise
+	= const $ parseError l "Kind signature only allowed for type variables"
     collect (L l (HsSpliceTy _      )) = 
       const $ parseError l "Splice not allowed as type parameter"
+    collect (L _ (HsDocTy t _       )) = collect t
 
         -- Collect all variables of a list of types
     collects []     = return
@@ -634,6 +635,7 @@ checkDoMDo _   nm loc []   = parseError loc ("Empty " ++ nm ++ " construct")
 checkDoMDo pre nm _   ss   = do
   check ss
   where 
+	check  []                     = panic "RdrHsSyn:checkDoMDo"
 	check  [L _ (ExprStmt e _ _)] = return ([], e)
 	check  [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
 					 " construct must be an expression")
-- 
1.7.10.4