X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fparser%2FParser.y.pp;h=7ab7c447b213a0e3904ff4ebaa7252182043ed88;hb=5e54b553bbb112167412ee9164135d56b06f5721;hp=6f1b2e449f418636bf87676b712de866aba0afb4;hpb=0cbdc7b1bd76c61ad31a14a43398ae05ce138489;p=ghc-hetmet.git

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 6f1b2e4..7ab7c44 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -8,7 +8,15 @@
 -- ---------------------------------------------------------------------------
 
 {
-{-# OPTIONS -Wwarn -w #-}
+{-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-}
+-- The NoMonomorphismRestriction deals with a Happy infelicity
+--    With OutsideIn's more conservativ monomorphism restriction
+--    we aren't generalising
+--        notHappyAtAll = error "urk"
+--    which is terrible.  Switching off the restriction allows
+--    the generalisation.  Better would be to make Happy generate
+--    an appropriate signature.
+
 -- 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
@@ -48,8 +56,7 @@ import StaticFlags	( opt_SccProfilingOn, opt_Hpc )
 import Type		( Kind, liftedTypeKind, unliftedTypeKind )
 import Coercion		( mkArrowKind )
 import Class		( FunDep )
-import BasicTypes	( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
-			  Activation(..), RuleMatchInfo(..), defaultInlinePragma )
+import BasicTypes
 import DynFlags
 import OrdList
 import HaddockUtils
@@ -253,8 +260,7 @@ incorrect.
  'by'       { L _ ITby }        -- for list transform extension
  'using'    { L _ ITusing }     -- for list transform extension
 
- '{-# INLINE'      	  { L _ (ITinline_prag _) }
- '{-# INLINE_CONLIKE'     { L _ (ITinline_conlike_prag _) }
+ '{-# INLINE'      	  { L _ (ITinline_prag _ _) }
  '{-# SPECIALISE'  	  { L _ ITspec_prag }
  '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _) }
  '{-# SOURCE'	   { L _ ITsource_prag }
@@ -783,8 +789,8 @@ decllist :: { Located (OrdList (LHsDecl RdrName)) }
 binds 	::  { Located (HsLocalBinds RdrName) } 		-- May have implicit parameters
 						-- No type declarations
 	: decllist			{ L1 (HsValBinds (cvBindGroup (unLoc $1))) }
-	| '{'            dbinds '}'	{ LL (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
-	|     vocurly    dbinds close	{ L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
+	| '{'            dbinds '}'	{ LL (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
+	|     vocurly    dbinds close	{ L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
 
 wherebinds :: { Located (HsLocalBinds RdrName) }	-- May have implicit parameters
 						-- No type declarations
@@ -1230,14 +1236,12 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
 	| infix prec ops	{ LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
 					     | n <- unLoc $3 ] }
 	| '{-# INLINE'   activation qvar '#-}'	      
-		{ LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma $2 FunLike (getINLINE $1)))) }
-        | '{-# INLINE_CONLIKE' activation qvar '#-}'
-                { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma $2 ConLike (getINLINE_CONLIKE $1)))) }
+		{ LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) }
 	| '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
 		{ LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlinePragma) 
 					    | t <- $4] }
 	| '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
-		{ LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma $2 FunLike (getSPEC_INLINE $1)))
+		{ LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma (getSPEC_INLINE $1) $2))
 					    | t <- $5] }
 	| '{-# SPECIALISE' 'instance' inst_type '#-}'
 		{ LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
@@ -1980,9 +1984,9 @@ getPRIMWORD	(L _ (ITprimword x)) = x
 getPRIMFLOAT	(L _ (ITprimfloat  x)) = x
 getPRIMDOUBLE	(L _ (ITprimdouble x)) = x
 getTH_ID_SPLICE (L _ (ITidEscape x)) = x
-getINLINE	(L _ (ITinline_prag b)) = b
-getINLINE_CONLIKE (L _ (ITinline_conlike_prag b)) = b
-getSPEC_INLINE	(L _ (ITspec_inline_prag b)) = b
+getINLINE	(L _ (ITinline_prag inl conl)) = (inl,conl)
+getSPEC_INLINE	(L _ (ITspec_inline_prag True))  = (Inline,  FunLike)
+getSPEC_INLINE	(L _ (ITspec_inline_prag False)) = (NoInline,FunLike)
 
 getDOCNEXT (L _ (ITdocCommentNext x)) = x
 getDOCPREV (L _ (ITdocCommentPrev x)) = x