projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Add bang patterns
[ghc-hetmet.git] / ghc / compiler / parser / Parser.y.pp
diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp
index 4a1519a..156cedc 100644 (file)
--- a/ghc/compiler/parser/Parser.y.pp
+++ b/ghc/compiler/parser/Parser.y.pp
@@ -25,7 +25,7 @@ import Type           ( funTyCon )
 import ForeignCall     ( Safety(..), CExportSpec(..), CLabelString,
                          CCallConv(..), CCallTarget(..), defaultCCallConv
                        )
-import OccName         ( UserFS, varName, dataName, tcClsName, tvName )
+import OccName         ( varName, dataName, tcClsName, tvName )
 import DataCon         ( DataCon, dataConName )
 import SrcLoc          ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
                          SrcSpan, combineLocs, srcLocFile, 
@@ -34,9 +34,8 @@ import Module
 import StaticFlags     ( opt_SccProfilingOn )
 import Type            ( Kind, mkArrowKind, liftedTypeKind )
 import BasicTypes      ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
-                         Activation(..), InlineSpec(..), defaultInlineSpec )
+                         Activation(..), defaultInlineSpec )
 import OrdList
-import Panic
 
 import FastString
 import Maybes          ( orElse )
@@ -455,20 +454,16 @@ tycl_decl :: { LTyClDecl RdrName }
                {% do { (tc,tvs) <- checkSynHdr $2
                      ; return (LL (TySynonym tc tvs $4)) } }
 
-       | 'data' tycl_hdr constrs deriving
+       | data_or_newtype tycl_hdr constrs deriving
                { L (comb4 $1 $2 $3 $4) -- We need the location on tycl_hdr 
                                        -- in case constrs and deriving are both empty
-                   (mkTyData DataType $2 Nothing (reverse (unLoc $3)) (unLoc $4)) }
+                   (mkTyData (unLoc $1) (unLoc $2) Nothing (reverse (unLoc $3)) (unLoc $4)) }
 
-        | 'data' tycl_hdr opt_kind_sig 
+        | data_or_newtype tycl_hdr opt_kind_sig 
                 'where' gadt_constrlist
                 deriving
                { L (comb4 $1 $2 $4 $5)
-                   (mkTyData DataType $2 $3 (reverse (unLoc $5)) (unLoc $6)) }
-
-       | 'newtype' tycl_hdr '=' newconstr deriving
-               { L (comb3 $1 $4 $5)
-                   (mkTyData NewType $2 Nothing [$4] (unLoc $5)) }
+                   (mkTyData (unLoc $1) (unLoc $2) $3 (reverse (unLoc $5)) (unLoc $6)) }
 
        | 'class' tycl_hdr fds where
                { let 
@@ -477,6 +472,10 @@ tycl_decl :: { LTyClDecl RdrName }
                  L (comb4 $1 $2 $3 $4) (mkClassDecl (unLoc $2) (unLoc $3) sigs 
                                          binds) }
 
+data_or_newtype :: { Located NewOrData }
+       : 'data'        { L1 DataType }
+       | 'newtype'     { L1 NewType }
+
 opt_kind_sig :: { Maybe Kind }
        :                               { Nothing }
        | '::' kind                     { Just $2 }
@@ -775,7 +774,7 @@ gentype :: { LHsType RdrName }
         : btype                         { $1 }
         | btype qtyconop gentype        { LL $ HsOpTy $1 $2 $3 }
         | btype tyvarop  gentype       { LL $ HsOpTy $1 $2 $3 }
-       | btype '->' gentype            { LL $ HsFunTy $1 $3 }
+       | btype '->' ctype              { LL $ HsFunTy $1 $3 }
 
 btype :: { LHsType RdrName }
        : btype atype                   { LL $ HsAppTy $1 $2 }
@@ -785,10 +784,10 @@ atype :: { LHsType RdrName }
        : gtycon                        { L1 (HsTyVar (unLoc $1)) }
        | tyvar                         { L1 (HsTyVar (unLoc $1)) }
        | strict_mark atype             { LL (HsBangTy (unLoc $1) $2) }
-       | '(' type ',' comma_types1 ')' { LL $ HsTupleTy Boxed  ($2:$4) }
+       | '(' ctype ',' comma_types1 ')'  { LL $ HsTupleTy Boxed  ($2:$4) }
        | '(#' comma_types1 '#)'        { LL $ HsTupleTy Unboxed $2     }
-       | '[' type ']'                  { LL $ HsListTy  $2 }
-       | '[:' type ':]'                { LL $ HsPArrTy  $2 }
+       | '[' ctype ']'                 { LL $ HsListTy  $2 }
+       | '[:' ctype ':]'               { LL $ HsPArrTy  $2 }
        | '(' ctype ')'                 { LL $ HsParTy   $2 }
        | '(' ctype '::' kind ')'       { LL $ HsKindSig $2 $4 }
 -- Generics
@@ -810,8 +809,8 @@ comma_types0  :: { [LHsType RdrName] }
        | {- empty -}                   { [] }
 
 comma_types1   :: { [LHsType RdrName] }
-       : type                          { [$1] }
-       | type  ',' comma_types1        { $1 : $3 }
+       : ctype                         { [$1] }
+       | ctype  ',' comma_types1       { $1 : $3 }
 
 tv_bndrs :: { [LHsTyVarBndr RdrName] }
         : tv_bndr tv_bndrs             { $1 : $2 }
@@ -852,11 +851,6 @@ akind      :: { Kind }
 -----------------------------------------------------------------------------
 -- Datatype declarations
 
-newconstr :: { LConDecl RdrName }
-       : conid atype   { LL $ ConDecl $1 Explicit [] (noLoc []) (PrefixCon [$2]) ResTyH98 }
-       | conid '{' var '::' ctype '}'
-                       { LL $ ConDecl $1 Explicit [] (noLoc []) (RecCon [($3, $5)]) ResTyH98 }
-
 gadt_constrlist :: { Located [LConDecl RdrName] }
        : '{'            gadt_constrs '}'       { LL (unLoc $2) }
        |     vocurly    gadt_constrs close     { $2 }
@@ -974,6 +968,10 @@ deriving :: { Located (Maybe [LHsType RdrName]) }
 
 decl   :: { Located (OrdList (LHsDecl RdrName)) }
        : sigdecl                       { $1 }
+       | '!' infixexp rhs              {% do { pat <- checkPattern $2;
+                                               return (LL $ unitOL $ LL $ ValD $ 
+                                                       PatBind (LL $ BangPat pat) (unLoc $3)
+                                                               placeHolderType placeHolderNames) } }
        | infixexp opt_sig rhs          {% do { r <- checkValDef $1 $2 $3;
                                                return (LL $ unitOL (LL $ ValD r)) } }
 
@@ -1069,6 +1067,7 @@ aexps     :: { [LHsExpr RdrName] }
 aexp   :: { LHsExpr RdrName }
        : qvar '@' aexp                 { LL $ EAsPat $1 $3 }
        | '~' aexp                      { LL $ ELazyPat $2 }
+--     | '!' aexp                      { LL $ EBangPat $2 }
        | aexp1                         { $1 }
 
 aexp1  :: { LHsExpr RdrName }
@@ -1092,7 +1091,7 @@ aexp2     :: { LHsExpr RdrName }
        | INTEGER                       { L1 (HsOverLit $! mkHsIntegral (getINTEGER $1)) }
        | RATIONAL                      { L1 (HsOverLit $! mkHsFractional (getRATIONAL $1)) }
        | '(' exp ')'                   { LL (HsPar $2) }
-       | '(' exp ',' texps ')'         { LL $ ExplicitTuple ($2 : reverse $4) Boxed }
+       | '(' texp ',' texps ')'        { LL $ ExplicitTuple ($2 : reverse $4) Boxed }
        | '(#' texps '#)'               { LL $ ExplicitTuple (reverse $2)      Unboxed }
        | '[' list ']'                  { LL (unLoc $2) }
        | '[:' parr ':]'                { LL (unLoc $2) }
@@ -1134,9 +1133,15 @@ cvtopdecls0 :: { [LHsDecl RdrName] }
        : {- empty -}           { [] }
        | cvtopdecls            { $1 }
 
+texp :: { LHsExpr RdrName }
+       : exp                           { $1 }
+       | qopm infixexp                 { LL $ SectionR $1 $2 }
+       -- The second production is really here only for bang patterns
+       -- but 
+
 texps :: { [LHsExpr RdrName] }
-       : texps ',' exp                 { $3 : $1 }
-       | exp                           { [$1] }
+       : texps ',' texp                { $3 : $1 }
+       | texp                          { [$1] }
 
 
 -----------------------------------------------------------------------------
@@ -1146,17 +1151,17 @@ texps :: { [LHsExpr RdrName] }
 -- avoiding another shift/reduce-conflict.
 
 list :: { LHsExpr RdrName }
-       : exp                   { L1 $ ExplicitList placeHolderType [$1] }
+       : texp                  { L1 $ ExplicitList placeHolderType [$1] }
        | lexps                 { L1 $ ExplicitList placeHolderType (reverse (unLoc $1)) }
-       | exp '..'              { LL $ ArithSeq noPostTcExpr (From $1) }
-       | exp ',' exp '..'      { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) }
-       | exp '..' exp          { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) }
-       | exp ',' exp '..' exp  { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) }
-       | exp pquals            { sL (comb2 $1 $>) $ mkHsDo ListComp (reverse (unLoc $2)) $1 }
+       | texp '..'             { LL $ ArithSeq noPostTcExpr (From $1) }
+       | texp ',' exp '..'     { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) }
+       | texp '..' exp         { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) }
+       | texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) }
+       | texp pquals           { sL (comb2 $1 $>) $ mkHsDo ListComp (reverse (unLoc $2)) $1 }
 
 lexps :: { Located [LHsExpr RdrName] }
-       : lexps ',' exp                 { LL ($3 : unLoc $1) }
-       | exp ',' exp                   { LL [$3,$1] }
+       : lexps ',' texp                { LL ($3 : unLoc $1) }
+       | texp ',' texp                 { LL [$3,$1] }
 
 -----------------------------------------------------------------------------
 -- List Comprehensions
@@ -1266,7 +1271,7 @@ stmt  :: { LStmt RdrName }
        | 'rec' stmtlist                { LL $ mkRecStmt (unLoc $2) }
 
 qual  :: { LStmt RdrName }
-       : infixexp '<-' exp             {% checkPattern $1 >>= \p ->
+       : exp '<-' exp                  {% checkPattern $1 >>= \p ->
                                           return (LL $ mkBindStmt p $3) }
        | exp                           { L1 $ mkExprStmt $1 }
        | 'let' binds                   { LL $ LetStmt (unLoc $2) }
@@ -1475,7 +1480,7 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-'
 -- These special_ids are treated as keywords in various places, 
 -- but as ordinary ids elsewhere.   'special_id' collects all these
 -- except 'unsafe' and 'forall' whose treatment differs depending on context
-special_id :: { Located UserFS }
+special_id :: { Located FastString }
 special_id
        : 'as'                  { L1 FSLIT("as") }
        | 'qualified'           { L1 FSLIT("qualified") }
@@ -1486,7 +1491,7 @@ special_id
        | 'stdcall'             { L1 FSLIT("stdcall") }
        | 'ccall'               { L1 FSLIT("ccall") }
 
-special_sym :: { Located UserFS }
+special_sym :: { Located FastString }
 special_sym : '!'      { L1 FSLIT("!") }
            | '.'       { L1 FSLIT(".") }
            | '*'       { L1 FSLIT("*") }
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)