X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=e4285ba9d653e13d695725bf95cee32b4eb84756;hb=579bc757533c8c9e5beabe5b21daddd922c1af75;hp=bfcc856e6edcce83b91a490a25634b2913965d6f;hpb=6821c8a47c0fc61a2d989d368f926cc0ded776e9;p=ghc-hetmet.git

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index bfcc856..e4285ba 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -378,7 +378,7 @@ module 	:: { Located (HsModule RdrName) }
                           Nothing)) }
 
 maybedocheader :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }
-        : moduleheader            { (fst $1, snd $1) }
+        : moduleheader            { $1 }
         | {- empty -}             { (emptyHaddockModInfo, Nothing) }
 
 missing_module_keyword :: { () }
@@ -606,8 +606,8 @@ ty_decl :: { LTyClDecl RdrName }
 	| data_or_newtype tycl_hdr constrs deriving
 		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
                       ; checkTyVars tparms    -- no type pattern
-		      ; return $
-			  L (comb4 $1 $2 $3 $4)
+		      ; return $!
+			  sL (comb4 $1 $2 $3 $4)
 			           -- We need the location on tycl_hdr in case 
 				   -- constrs and deriving are both empty
 			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 
@@ -619,8 +619,8 @@ ty_decl :: { LTyClDecl RdrName }
 		 deriving
 		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
                       ; checkTyVars tparms    -- can have type pats
-		      ; return $
-			  L (comb4 $1 $2 $4 $5)
+		      ; return $!
+			  sL (comb4 $1 $2 $4 $5)
 			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 
 			      (unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } }
 
@@ -1309,8 +1309,8 @@ exp10 :: { LHsExpr RdrName }
 
 scc_annot :: { Located FastString }
 	: '_scc_' STRING			{% (addWarning Opt_WarnDeprecations (getLoc $1) (text "_scc_ is deprecated; use an SCC pragma instead")) >>= \_ ->
-                                   (return $ LL $ getSTRING $2) }
-	| '{-# SCC' STRING '#-}'		{ LL $ getSTRING $2 }
+                                   ( do scc <- getSCC $2; return $ LL scc ) }
+	| '{-# SCC' STRING '#-}'		{% do scc <- getSCC $2; return $ LL scc }
 
 hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) }
 	: '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
@@ -1969,6 +1969,14 @@ getDOCPREV (L _ (ITdocCommentPrev x)) = x
 getDOCNAMED (L _ (ITdocCommentNamed x)) = x
 getDOCSECTION (L _ (ITdocSection n x)) = (n, x)
 
+getSCC :: Located Token -> P FastString
+getSCC lt = do let s = getSTRING lt
+                   err = "Spaces are not allowed in SCCs"
+               -- We probably actually want to be more restrictive than this
+               if ' ' `elem` unpackFS s
+                   then failSpanMsgP (getLoc lt) (text err)
+                   else return s
+
 -- Utilities for combining source spans
 comb2 :: Located a -> Located b -> SrcSpan
 comb2 a b = a `seq` b `seq` combineLocs a b