X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=e7c991b36a3bc6a99b6a96f0ccb7ea62aefc3526;hp=6dbb49e9819eea7c3951ad50c41543f8de4a8c33;hb=c75d5fc876279575226ec22a27ce056851128ade;hpb=c281c07544cc58afe68fdda96afe53ba46985732

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 6dbb49e..e7c991b 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
@@ -262,9 +263,9 @@ incorrect.
  '{-# SCC'	   { L _ ITscc_prag }
  '{-# GENERATED'   { L _ ITgenerated_prag }
  '{-# DEPRECATED'  { L _ ITdeprecated_prag }
- '{-# WARNING'  { L _ ITwarning_prag }
+ '{-# WARNING'     { L _ ITwarning_prag }
  '{-# UNPACK'      { L _ ITunpack_prag }
- '{-# ANN'      { L _ ITann_prag }
+ '{-# ANN'         { L _ ITann_prag }
  '#-}'		   { L _ ITclose_prag }
 
  '..'		{ L _ ITdotdot }  			-- reserved symbols
@@ -559,17 +560,17 @@ 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 }
 
 	-- Template Haskell Extension
-	| '$(' exp ')'				{ unitOL (LL $ SpliceD (SpliceDecl $2)) }
-	| TH_ID_SPLICE				{ unitOL (LL $ SpliceD (SpliceDecl $
-							L1 $ HsVar (mkUnqual varName (getTH_ID_SPLICE $1))
-						  )) }
+	-- The $(..) form is one possible form of infixexp
+	-- but we treat an arbitrary expression just as if 
+	-- it had a $(..) wrapped around it
+	| infixexp 				{ unitOL (LL $ mkTopSpliceDecl $1) } 
 
 -- Type classes
 --
@@ -981,7 +982,7 @@ context :: { LHsContext RdrName }
 
 type :: { LHsType RdrName }
         : btype                         { $1 }
-        | btype qtyconop type        { LL $ HsOpTy $1 $2 $3 }
+        | btype qtyconop type           { LL $ HsOpTy $1 $2 $3 }
         | btype tyvarop  type     	{ LL $ HsOpTy $1 $2 $3 }
  	| btype '->'     ctype		{ LL $ HsFunTy $1 $3 }
         | btype '~'      btype  	{ LL $ HsPredTy (HsEqualP $1 $3) }
@@ -1167,7 +1168,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,26 +1222,25 @@ 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
@@ -1415,7 +1417,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] }
@@ -1456,35 +1458,27 @@ lexps :: { Located [LHsExpr RdrName] }
 
 flattenedpquals :: { Located [LStmt RdrName] }
     : pquals   { case (unLoc $1) of
-                    ParStmt [(qs, _)] -> L1 qs
+                    [qs] -> L1 qs
                     -- We just had one thing in our "parallel" list so 
                     -- we simply return that thing directly
                     
-                    _ -> L1 [$1]
+                    qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss]]
                     -- We actually found some actual parallel lists so
-                    -- we leave them into as a ParStmt
+                    -- we wrap them into as a ParStmt
                 }
 
-pquals :: { LStmt RdrName }
-    : pquals1   { L1 (ParStmt [(qs, undefined) | qs <- (reverse (unLoc $1))]) }
+pquals :: { Located [[LStmt RdrName]] }
+    : squals '|' pquals     { L (getLoc $2) (reverse (unLoc $1) : unLoc $3) }
+    | squals                { L (getLoc $1) [reverse (unLoc $1)] }
 
-pquals1 :: { Located [[LStmt RdrName]] }
-    : pquals1 '|' squals    { LL (unLoc $3 : unLoc $1) }
-    | squals                { L (getLoc $1) [unLoc $1] }
-
-squals :: { Located [LStmt RdrName] }
-    : squals1               { L (getLoc $1) (reverse (unLoc $1)) }
-
-squals1 :: { Located [LStmt RdrName] }
-    : transformquals1       { LL (unLoc $1) }
-
-transformquals1 :: { Located [LStmt RdrName] }
-    : transformquals1 ',' transformqual         { LL $ [LL ((unLoc $3) (unLoc $1))] }
-    | transformquals1 ',' qual                  { LL ($3 : unLoc $1) }
---  | transformquals1 ',' '{|' pquals '|}'      { LL ($4 : unLoc $1) }
-    | transformqual                             { LL $ [LL ((unLoc $1) [])] }
-    | qual                                      { L1 [$1] }
---  | '{|' pquals '|}'                          { L1 [$2] }
+squals :: { Located [LStmt RdrName] }	-- In reverse order, because the last 
+					-- one can "grab" the earlier ones
+    : squals ',' transformqual         	     { LL [L (getLoc $3) ((unLoc $3) (reverse (unLoc $1)))] }
+    | squals ',' qual                  	     { LL ($3 : unLoc $1) }
+    | transformqual                          { LL [L (getLoc $1) ((unLoc $1) [])] }
+    | qual                                   { L1 [$1] }
+--  | transformquals1 ',' '{|' pquals '|}'   { LL ($4 : unLoc $1) }
+--  | '{|' pquals '|}'                       { L1 [$2] }
 
 
 -- It is possible to enable bracketing (associating) qualifier lists by uncommenting the lines with {| |}
@@ -1493,10 +1487,11 @@ transformquals1 :: { Located [LStmt RdrName] }
 -- a program that makes use of this temporary syntax you must supply that flag to GHC
 
 transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) }
-    : 'then' exp                { LL $ \leftStmts -> (mkTransformStmt (reverse leftStmts) $2) }
+			-- Function is applied to a list of stmts *in order*
+    : 'then' exp                { LL $ \leftStmts -> (mkTransformStmt leftStmts $2) }
     -- >>>
-    | 'then' exp 'by' exp       { LL $ \leftStmts -> (mkTransformByStmt (reverse leftStmts) $2 $4) }
-    | 'then' 'group' 'by' exp              { LL $ \leftStmts -> (mkGroupByStmt (reverse leftStmts) $4) }
+    | 'then' exp 'by' exp       { LL $ \leftStmts -> (mkTransformByStmt leftStmts $2 $4) }
+    | 'then' 'group' 'by' exp   { LL $ \leftStmts -> (mkGroupByStmt leftStmts $4) }
     -- <<<
     -- These two productions deliberately have a shift-reduce conflict. I have made 'group' into a special_id,
     -- which means you can enable TransformListComp while still using Data.List.group. However, this makes the two
@@ -1506,8 +1501,8 @@ transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) }
     -- This is rather dubious: the user might be confused as to how to parse this statement. However, it is a good
     -- practical choice. NB: Data.List.group :: [a] -> [[a]], so using the first production would not even type check
     -- if /that/ is the group function we conflict with.
-    | 'then' 'group' 'using' exp           { LL $ \leftStmts -> (mkGroupUsingStmt (reverse leftStmts) $4) }
-    | 'then' 'group' 'by' exp 'using' exp  { LL $ \leftStmts -> (mkGroupByUsingStmt (reverse leftStmts) $4 $6) }
+    | 'then' 'group' 'using' exp           { LL $ \leftStmts -> (mkGroupUsingStmt leftStmts $4) }
+    | 'then' 'group' 'by' exp 'using' exp  { LL $ \leftStmts -> (mkGroupByUsingStmt leftStmts $4 $6) }
 
 -----------------------------------------------------------------------------
 -- Parallel array expressions
@@ -2019,6 +2014,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)
 }