projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Add the notion of "constructor-like" Ids for rule-matching
[ghc-hetmet.git] / compiler / parser / Parser.y.pp
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 86ce98c..5fbbcad 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -47,7 +47,7 @@ import Module
 import StaticFlags     ( opt_SccProfilingOn, opt_Hpc )
 import Type            ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind )
 import BasicTypes      ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
-                         Activation(..), defaultInlineSpec )
+                         Activation(..), RuleMatchInfo(..), defaultInlineSpec )
 import DynFlags
 import OrdList
 import HaddockParse
@@ -254,6 +254,7 @@ incorrect.
  'using'    { L _ ITusing }     -- for list transform extension
 
  '{-# INLINE'            { L _ (ITinline_prag _) }
+ '{-# INLINE_CONLIKE'     { L _ (ITinline_conlike_prag _) }
  '{-# SPECIALISE'        { L _ ITspec_prag }
  '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _) }
  '{-# SOURCE'     { L _ ITsource_prag }
@@ -264,6 +265,7 @@ incorrect.
  '{-# DEPRECATED'  { L _ ITdeprecated_prag }
  '{-# WARNING'  { L _ ITwarning_prag }
  '{-# UNPACK'      { L _ ITunpack_prag }
+ '{-# ANN'      { L _ ITann_prag }
  '#-}'            { L _ ITclose_prag }
 
  '..'          { L _ ITdotdot }                        -- reserved symbols
@@ -314,6 +316,8 @@ incorrect.
  QCONID        { L _ (ITqconid   _) }
  QVARSYM       { L _ (ITqvarsym  _) }
  QCONSYM       { L _ (ITqconsym  _) }
+ PREFIXQVARSYM  { L _ (ITprefixqvarsym  _) }
+ PREFIXQCONSYM  { L _ (ITprefixqconsym  _) }
 
  IPDUPVARID    { L _ (ITdupipvarid   _) }              -- GHC extension
 
@@ -495,13 +499,17 @@ importdecls :: { [LImportDecl RdrName] }
        | {- empty -}                           { [] }
 
 importdecl :: { LImportDecl RdrName }
-       : 'import' maybe_src optqualified modid maybeas maybeimpspec 
-               { L (comb4 $1 $4 $5 $6) (ImportDecl $4 $2 $3 (unLoc $5) (unLoc $6)) }
+       : 'import' maybe_src optqualified maybe_pkg modid maybeas maybeimpspec 
+               { L (comb4 $1 $5 $6 $7) (ImportDecl $5 $4 $2 $3 (unLoc $6) (unLoc $7)) }
 
 maybe_src :: { IsBootInterface }
        : '{-# SOURCE' '#-}'                    { True }
        | {- empty -}                           { False }
 
+maybe_pkg :: { Maybe FastString }
+        : STRING                                { Just (getSTRING $1) }
+        | {- empty -}                           { Nothing }
+
 optqualified :: { Bool }
        : 'qualified'                           { True  }
        | {- empty -}                           { False }
@@ -555,6 +563,7 @@ topdecl :: { OrdList (LHsDecl RdrName) }
     | '{-# DEPRECATED' deprecations '#-}' { $2 }
     | '{-# WARNING' warnings '#-}'        { $2 }
        | '{-# RULES' rules '#-}'               { $2 }
+       | annotation { unitOL $1 }
        | decl                                  { unLoc $1 }
 
        -- Template Haskell Extension
@@ -920,6 +929,13 @@ deprecation :: { OrdList (LHsDecl RdrName) }
                { toOL [ LL $ WarningD (Warning n (DeprecatedTxt (getSTRING $2)))
                       | n <- unLoc $1 ] }
 
+-----------------------------------------------------------------------------
+-- Annotations
+annotation :: { LHsDecl RdrName }
+    : '{-# ANN' name_var aexp '#-}'      { LL (AnnD $ HsAnnotation (ValueAnnProvenance (unLoc $2)) $3) }
+    | '{-# ANN' 'type' tycon aexp '#-}'  { LL (AnnD $ HsAnnotation (TypeAnnProvenance (unLoc $3)) $4) }
+    | '{-# ANN' 'module' aexp '#-}'      { LL (AnnD $ HsAnnotation ModuleAnnProvenance $3) }
+
 
 -----------------------------------------------------------------------------
 -- Foreign import and export declarations
@@ -1272,12 +1288,14 @@ 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 (mkInlineSpec $2 (getINLINE $1)))) }
+                               { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 FunLike (getINLINE $1)))) }
+        | '{-# INLINE_CONLIKE' activation qvar '#-}'
+                                { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 ConLike (getINLINE_CONLIKE $1)))) }
        | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
                                { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec) 
                                            | t <- $4] }
        | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
-                               { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 (getSPEC_INLINE $1)))
+                               { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 FunLike (getSPEC_INLINE $1)))
                                            | t <- $5] }
        | '{-# SPECIALISE' 'instance' inst_type '#-}'
                                { LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
@@ -1429,16 +1447,27 @@ cvtopdecls0 :: { [LHsDecl RdrName] }
        : {- empty -}           { [] }
        | cvtopdecls            { $1 }
 
--- tuple expressions: things that can appear unparenthesized as long as they're
+-- "texp" is short for tuple expressions: 
+-- things that can appear unparenthesized as long as they're
 -- inside parens or delimitted by commas
 texp :: { LHsExpr RdrName }
        : exp                           { $1 }
-       -- Technically, this should only be used for bang patterns,
-       -- but we can be a little more liberal here and avoid parens
-       -- inside tuples
-       | infixexp qop  { LL $ SectionL $1 $2 }
+
+       -- Note [Parsing sections]
+       -- ~~~~~~~~~~~~~~~~~~~~~~~
+       -- We include left and right sections here, which isn't
+       -- technically right according to Haskell 98.  For example
+       --      (3 +, True) isn't legal
+       -- However, we want to parse bang patterns like
+       --      (!x, !y)
+       -- and it's convenient to do so here as a section
+        -- Then when converting expr to pattern we unravel it again
+       -- Meanwhile, the renamer checks that real sections appear
+       -- inside parens.
+        | infixexp qop         { LL $ SectionL $1 $2 }
        | qopm infixexp       { LL $ SectionR $1 $2 }
-       -- view patterns get parenthesized above
+
+       -- View patterns get parenthesized above
        | exp '->' exp   { LL $ EViewPat $1 $3 }
 
 texps :: { [LHsExpr RdrName] }
@@ -1724,6 +1753,7 @@ qtyconop :: { Located RdrName }   -- Qualified or unqualified
 
 qtycon :: { Located RdrName }  -- Qualified or unqualified
        : QCONID                        { L1 $! mkQual tcClsName (getQCONID $1) }
+        | PREFIXQCONSYM                 { L1 $! mkQual tcClsName (getPREFIXQCONSYM $1) }
        | tycon                         { $1 }
 
 tycon  :: { Located RdrName }  -- Unqualified
@@ -1804,17 +1834,15 @@ qvar    :: { Located RdrName }
 
 qvarid :: { Located RdrName }
        : varid                 { $1 }
-       | QVARID                { L1 $ mkQual varName (getQVARID $1) }
+       | QVARID                { L1 $! mkQual varName (getQVARID $1) }
+        | PREFIXQVARSYM         { L1 $! mkQual varName (getPREFIXQVARSYM $1) }
 
 varid :: { Located RdrName }
-       : varid_no_unsafe       { $1 }
+       : VARID                 { L1 $! mkUnqual varName (getVARID $1) }
+       | special_id            { L1 $! mkUnqual varName (unLoc $1) }
        | 'unsafe'              { L1 $! mkUnqual varName (fsLit "unsafe") }
        | 'safe'                { L1 $! mkUnqual varName (fsLit "safe") }
        | 'threadsafe'          { L1 $! mkUnqual varName (fsLit "threadsafe") }
-
-varid_no_unsafe :: { Located RdrName }
-       : VARID                 { L1 $! mkUnqual varName (getVARID $1) }
-       | special_id            { L1 $! mkUnqual varName (unLoc $1) }
        | 'forall'              { L1 $! mkUnqual varName (fsLit "forall") }
        | 'family'              { L1 $! mkUnqual varName (fsLit "family") }
 
@@ -1863,7 +1891,8 @@ special_sym : '!' { L1 (fsLit "!") }
 
 qconid :: { Located RdrName }  -- Qualified or unqualified
        : conid                 { $1 }
-       | QCONID                { L1 $ mkQual dataName (getQCONID $1) }
+       | QCONID                { L1 $! mkQual dataName (getQCONID $1) }
+        | PREFIXQCONSYM         { L1 $! mkQual dataName (getPREFIXQCONSYM $1) }
 
 conid  :: { Located RdrName }
        : CONID                 { L1 $ mkUnqual dataName (getCONID $1) }
@@ -1972,6 +2001,8 @@ getQVARID         (L _ (ITqvarid   x)) = x
 getQCONID      (L _ (ITqconid   x)) = x
 getQVARSYM     (L _ (ITqvarsym  x)) = x
 getQCONSYM     (L _ (ITqconsym  x)) = x
+getPREFIXQVARSYM (L _ (ITprefixqvarsym  x)) = x
+getPREFIXQCONSYM (L _ (ITprefixqconsym  x)) = x
 getIPDUPVARID   (L _ (ITdupipvarid   x)) = x
 getCHAR                (L _ (ITchar     x)) = x
 getSTRING      (L _ (ITstring   x)) = x
@@ -1985,6 +2016,7 @@ 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
 
 getDOCNEXT (L _ (ITdocCommentNext x)) = x
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)