Minor refactoring of placeHolderPunRhs

[ghc-hetmet.git] / compiler / parser / Parser.y.pp

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 4cd637f..42cb96f 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -45,7 +45,8 @@ 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(..), defaultInlinePragma )
@@ -1012,10 +1013,10 @@ atype :: { LHsType RdrName }
        | '[:' ctype ':]'               { LL $ HsPArrTy  $2 }
        | '(' ctype ')'                 { LL $ HsParTy   $2 }
        | '(' ctype '::' kind ')'       { LL $ HsKindSig $2 (unLoc $4) }
-       | '$(' exp ')'                  { LL $ HsSpliceTy (mkHsSplice $2 ) }
-       | TH_ID_SPLICE                  { LL $ HsSpliceTy (mkHsSplice 
-                                                (L1 $ HsVar (mkUnqual varName 
-                                                               (getTH_ID_SPLICE $1)))) } -- $x
+       | quasiquote                    { L1 (HsQuasiQuoteTy (unLoc $1)) }
+       | '$(' exp ')'                  { LL $ mkHsSpliceTy $2 }
+       | TH_ID_SPLICE                  { LL $ mkHsSpliceTy $ L1 $ HsVar $ 
+                                         mkUnqual varName (getTH_ID_SPLICE $1) }
 -- Generics
         | INTEGER                       { L1 (HsNumTy (getINTEGER $1)) }
 
@@ -1043,7 +1044,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
         | {- empty -}                  { [] }
 
 tv_bndr :: { LHsTyVarBndr RdrName }
-       : tyvar                         { L1 (UserTyVar (unLoc $1)) }
+       : tyvar                         { L1 (UserTyVar (unLoc $1) placeHolderKind) }
        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) 
                                                          (unLoc $4)) }
 
@@ -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,10 +1222,9 @@ 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))))
@@ -1243,6 +1245,12 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
 -----------------------------------------------------------------------------
 -- 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 }
@@ -1354,14 +1362,10 @@ aexp2   :: { LHsExpr RdrName }
        -- Template Haskell Extension
        | TH_ID_SPLICE          { L1 $ HsSpliceE (mkHsSplice 
                                        (L1 $ HsVar (mkUnqual varName 
-                                                       (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) }
+                                                       (getTH_ID_SPLICE $1)))) } 
+       | '$(' exp ')'          { LL $ HsSpliceE (mkHsSplice $2) }               
+
+
        | 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 +1374,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 +1419,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] }
@@ -1629,11 +1633,10 @@ fbinds1 :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) }
        | '..'                          { ([],   True) }
   
 fbind  :: { HsRecField RdrName (LHsExpr RdrName) }
-       : qvar '=' exp  { HsRecField $1 $3 False }
-        | qvar          { HsRecField $1 (L (getLoc $1) placeHolderPunRhs) True }
-                       -- Here's where we say that plain 'x'
-                       -- means exactly 'x = x'.  The pun-flag boolean is
-                       -- there so we can still print it right
+       : qvar '=' exp  { HsRecField $1 $3                False }
+        | qvar          { HsRecField $1 placeHolderPunRhs True }
+                       -- In the punning case, use a place-holder
+                        -- The renamer fills in the final value
 
 -----------------------------------------------------------------------------
 -- Implicit Parameter Bindings