X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=96088f400d0642a6cc9dad8af32af9d512012e9f;hp=895c8a868734c854929d1b1c3f81108eb6a7c4d4;hb=b1ab4b8a607addc4d097588db5761313c996a41f;hpb=90dc9026b091be5cca5da4c6cbd3713ecc493361

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 895c8a8..96088f4 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -17,7 +17,7 @@ module RdrHsSyn (
 	cvBindGroup,
         cvBindsAndSigs,
 	cvTopDecls,
-	findSplice, mkGroup,
+	findSplice, checkDecBrGroup,
 
 	-- Stuff to do with Foreign declarations
 	CallConv(..),
@@ -54,7 +54,7 @@ module RdrHsSyn (
 #include "HsVersions.h"
 
 import HsSyn		-- Lots of it
-import RdrName		( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, 
+import RdrName		( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
 			  isRdrDataCon, isUnqual, getRdrName, isQual,
 			  setRdrNameSpace )
 import BasicTypes	( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
@@ -69,7 +69,6 @@ import OrdList		( OrdList, fromOL )
 import Bag		( Bag, emptyBag, snocBag, consBag, foldrBag )
 import Outputable
 import FastString
-import Panic
 
 import List		( isSuffixOf, nubBy )
 import Monad		( unless )
@@ -281,14 +280,15 @@ has_args ((L _ (Match args _ _)) : _) = not (null args)
 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 findSplice ds = addl emptyRdrGroup ds
 
-mkGroup :: [LHsDecl a] -> HsGroup a
-mkGroup ds = addImpDecls emptyRdrGroup ds
-
-addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
--- The decls are imported, and should not have a splice
-addImpDecls group decls = case addl group decls of
-				(group', Nothing) -> group'
-				other		  -> panic "addImpDecls"
+checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
+-- Turn the body of a [d| ... |] into a HsGroup
+-- There should be no splices in the "..."
+checkDecBrGroup decls 
+  = case addl emptyRdrGroup decls of
+	(group, Nothing) -> return group
+	(_, Just (SpliceDecl (L loc _), _)) -> 
+		parseError loc "Declaration splices are not permitted inside declaration brackets"
+		-- Why not?  See Section 7.3 of the TH paper.  
 
 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 	-- This stuff reverses the declarations (again) but it doesn't matter
@@ -309,8 +309,6 @@ add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
 	| isClassDecl d = 	
 		let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
 		addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
-	| isFamInstDecl d = 
-	        addl (gp { hs_tyclds = L l d : ts }) ds
 	| otherwise =
 		addl (gp { hs_tyclds = L l d : ts }) ds
 
@@ -468,13 +466,12 @@ checkTyClHdr (L l cxt) ty
   where
     gol (L l ty) acc = go l ty acc
 
-    go l (HsTyVar tc)    acc 
-	| not (isRdrTyVar tc)   = do
-				    tvs <- extractTyVars acc
-				    return (L l tc, tvs, acc)
-    go l (HsOpTy t1 tc t2) acc  = do
-				    tvs <- extractTyVars (t1:t2:acc)
-				    return (tc, tvs, acc)
+    go l (HsTyVar tc) acc 
+	| isRdrTc tc 		= do tvs <- extractTyVars acc
+				     return (L l tc, tvs, acc)
+    go l (HsOpTy t1 ltc@(L _ tc) t2) acc
+	| isRdrTc tc		= do tvs <- extractTyVars (t1:t2:acc)
+				     return (ltc, tvs, acc)
     go l (HsParTy ty)    acc    = gol ty acc
     go l (HsAppTy t1 t2) acc    = gol t1 (t2:acc)
     go l other	         acc    = 
@@ -705,8 +702,8 @@ checkAPat loc e = case e of
    ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
    			 return (TuplePat ps b placeHolderType)
    
-   RecordCon c _ fs   -> mapM checkPatField fs >>= \fs ->
-			 return (ConPatIn c (RecCon (map (uncurry mkRecField) fs))) 
+   RecordCon c _ (HsRecordBinds fs)   -> mapM checkPatField fs >>= \fs ->
+			 return (ConPatIn c (RecCon (map (uncurry mkRecField) fs)))
 -- Generics 
    HsType ty          -> return (TypePat ty) 
    _                  -> patFail loc
@@ -873,9 +870,9 @@ mkRecConstrOrUpdate
 
 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
   = return (RecordCon (L l c) noPostTcExpr fs)
-mkRecConstrOrUpdate exp loc fs@(_:_)
-  = return (RecordUpd exp fs placeHolderType placeHolderType)
-mkRecConstrOrUpdate _ loc []
+mkRecConstrOrUpdate exp loc fs@(HsRecordBinds (_:_))
+  = return (RecordUpd exp fs [] [] [])
+mkRecConstrOrUpdate _ loc (HsRecordBinds [])
   = parseError loc "Empty record update"
 
 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec