X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=c56b0c10018d3a1c86cee526828810d821b904e8;hp=3aec9e3d70b14cd03cadbf32ce187061cedfa326;hb=26f164e5759e9eca73deb0531ddec422d36a6924;hpb=26caccd3a492556ecce7c36ce69cecc2ae7c5a75

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 3aec9e3..c56b0c1 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -45,10 +45,11 @@ import SrcLoc		( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
 			  mkSrcLoc, mkSrcSpan )
 import Module
 import StaticFlags	( opt_SccProfilingOn, opt_Hpc )
-import Type		( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind )
+import Type		( Kind, liftedTypeKind, unliftedTypeKind )
+import Coercion		( mkArrowKind )
 import Class		( FunDep )
 import BasicTypes	( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
-			  Activation(..), RuleMatchInfo(..), defaultInlineSpec )
+			  Activation(..), RuleMatchInfo(..), defaultInlinePragma )
 import DynFlags
 import OrdList
 import HaddockUtils
@@ -559,8 +560,8 @@ topdecl :: { OrdList (LHsDecl RdrName) }
         | stand_alone_deriving                  { unitOL (LL (DerivD (unLoc $1))) }
 	| 'default' '(' comma_types0 ')'	{ unitOL (LL $ DefD (DefaultDecl $3)) }
 	| 'foreign' fdecl			{ unitOL (LL (unLoc $2)) }
-        | '{-# DEPRECATED' deprecations '#-}' { $2 }
-        | '{-# WARNING' warnings '#-}'        { $2 }
+        | '{-# DEPRECATED' deprecations '#-}'   { $2 }
+        | '{-# WARNING' warnings '#-}'          { $2 }
 	| '{-# RULES' rules '#-}'		{ $2 }
 	| annotation { unitOL $1 }
       	| decl					{ unLoc $1 }
@@ -1012,10 +1013,12 @@ atype :: { LHsType RdrName }
 	| '[:' ctype ':]'		{ LL $ HsPArrTy  $2 }
 	| '(' ctype ')'		        { LL $ HsParTy   $2 }
 	| '(' ctype '::' kind ')'	{ LL $ HsKindSig $2 (unLoc $4) }
+	| quasiquote       	        { L1 (HsQuasiQuoteTy (unLoc $1)) }
 	| '$(' exp ')'	      		{ LL $ HsSpliceTy (mkHsSplice $2 ) }
 	| TH_ID_SPLICE	      		{ LL $ HsSpliceTy (mkHsSplice 
 					         (L1 $ HsVar (mkUnqual varName 
 							        (getTH_ID_SPLICE $1)))) } -- $x
+
 -- Generics
         | INTEGER                       { L1 (HsNumTy (getINTEGER $1)) }
 
@@ -1167,7 +1170,9 @@ deriving :: { Located (Maybe [LHsType RdrName]) }
 -----------------------------------------------------------------------------
 -- Value definitions
 
-{- There's an awkward overlap with a type signature.  Consider
+{- Note [Declaration/signature overlap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There's an awkward overlap with a type signature.  Consider
 	f :: Int -> Int = ...rhs...
    Then we can't tell whether it's a type signature or a value
    definition with a result signature until we see the '='.
@@ -1219,30 +1224,35 @@ gdrh :: { LGRHS RdrName }
 	: '|' guardquals '=' exp  	{ sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 }
 
 sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
-	: infixexp '::' sigtypedoc
-				{% do s <- checkValSig $1 $3; 
-				      return (LL $ unitOL (LL $ SigD s)) }
-		-- See the above notes for why we need infixexp here
+	: infixexp '::' sigtypedoc	{% do s <- checkValSig $1 $3 
+				         ; return (LL $ unitOL (LL $ SigD s)) }
+		-- See Note [Declaration/signature overlap] for why we need infixexp here
 	| var ',' sig_vars '::' sigtypedoc
 				{ LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] }
 	| 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 (mkInlineSpec $2 FunLike (getINLINE $1)))) }
+		{ LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma $2 FunLike (getINLINE $1)))) }
         | '{-# INLINE_CONLIKE' activation qvar '#-}'
-                                { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 ConLike (getINLINE_CONLIKE $1)))) }
+                { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma $2 ConLike (getINLINE_CONLIKE $1)))) }
 	| '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
-			 	{ LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec) 
+		{ LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlinePragma) 
 					    | t <- $4] }
 	| '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
-			 	{ LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 FunLike (getSPEC_INLINE $1)))
+		{ LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma $2 FunLike (getSPEC_INLINE $1)))
 					    | t <- $5] }
 	| '{-# SPECIALISE' 'instance' inst_type '#-}'
-				{ LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
+		{ LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
 
 -----------------------------------------------------------------------------
 -- Expressions
 
+quasiquote :: { Located (HsQuasiQuote RdrName) }
+	: TH_QUASIQUOTE   { let { loc = getLoc $1
+                                ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1
+                                ; quoterId = mkUnqual varName quoter }
+                            in L1 (mkHsQuasiQuote quoterId quoteSpan quote) }
+
 exp   :: { LHsExpr RdrName }
 	: infixexp '::' sigtype		{ LL $ ExprWithTySig $1 $3 }
 	| infixexp '-<' exp		{ LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True }
@@ -1357,11 +1367,7 @@ aexp2	:: { LHsExpr RdrName }
 							(getTH_ID_SPLICE $1)))) } -- $x
 	| '$(' exp ')'   	{ LL $ HsSpliceE (mkHsSplice $2) }               -- $( exp )
 
-	| TH_QUASIQUOTE       	{ let { loc = getLoc $1
-                                      ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1
-                                      ; quoterId = mkUnqual varName quoter
-                                      }
-                                  in sL loc $ HsQuasiQuoteE (mkHsQuasiQuote quoterId quoteSpan quote) }
+
 	| TH_VAR_QUOTE qvar 	{ LL $ HsBracket (VarBr (unLoc $2)) }
 	| TH_VAR_QUOTE qcon 	{ LL $ HsBracket (VarBr (unLoc $2)) }
 	| TH_TY_QUOTE tyvar 	{ LL $ HsBracket (VarBr (unLoc $2)) }
@@ -1370,8 +1376,8 @@ aexp2	:: { LHsExpr RdrName }
 	| '[t|' ctype '|]'      { LL $ HsBracket (TypBr $2) }                       
 	| '[p|' infixexp '|]'   {% checkPattern $2 >>= \p ->
 					return (LL $ HsBracket (PatBr p)) }
-	| '[d|' cvtopbody '|]'	{% checkDecBrGroup $2 >>= \g -> 
-					return (LL $ HsBracket (DecBr g)) }
+	| '[d|' cvtopbody '|]'	{ LL $ HsBracket (DecBrL $2) }
+	| quasiquote       	{ L1 (HsQuasiQuoteE (unLoc $1)) }
 
 	-- arrow notation extension
 	| '(|' aexp2 cmdargs '|)'	{ LL $ HsArrForm $2 Nothing (reverse $3) }
@@ -1415,7 +1421,7 @@ texp :: { LHsExpr RdrName }
 	| qopm infixexp       { LL $ SectionR $1 $2 }
 
        -- View patterns get parenthesized above
-	| exp '->' exp   { LL $ EViewPat $1 $3 }
+	| exp '->' texp   { LL $ EViewPat $1 $3 }
 
 -- Always at least one comma
 tup_exprs :: { [HsTupArg RdrName] }
@@ -2012,6 +2018,6 @@ sL span a = span `seq` a `seq` L span a
 fileSrcSpan :: P SrcSpan
 fileSrcSpan = do 
   l <- getSrcLoc; 
-  let loc = mkSrcLoc (srcLocFile l) 1 0;
+  let loc = mkSrcLoc (srcLocFile l) 1 1;
   return (mkSrcSpan loc loc)
 }