Remove the distinction between data and newtype families

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

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 55f8cf2..cc348bd 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -52,6 +52,17 @@ import Control.Monad    ( mplus )
 
 {-
 -----------------------------------------------------------------------------
+24 Februar 2006
+
+Conflicts: 33 shift/reduce
+           1 reduce/reduce
+
+The reduce/reduce conflict is weird.  It's between tyconsym and consym, and I
+would think the two should never occur in the same context.
+
+  -=chak
+
+-----------------------------------------------------------------------------
 31 December 2006
 
 Conflicts: 34 shift/reduce
@@ -350,10 +361,10 @@ module    :: { Located (HsModule RdrName) }
                {% fileSrcSpan >>= \ loc -> case $1 of { (opt, info, doc) -> 
                   return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4 
                           opt info doc) )}}
-       | missing_module_keyword top close
+        | body2
                {% fileSrcSpan >>= \ loc ->
                   return (L loc (HsModule Nothing Nothing 
-                          (fst $2) (snd $2) Nothing Nothing emptyHaddockModInfo 
+                          (fst $1) (snd $1) Nothing Nothing emptyHaddockModInfo 
                           Nothing)) }
 
 optdoc :: { (Maybe String, HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }                             
@@ -374,6 +385,10 @@ body       :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
        :  '{'            top '}'               { $2 }
        |      vocurly    top close             { $2 }
 
+body2  :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
+       :  '{' top '}'                          { $2 }
+       |  missing_module_keyword top close     { $2 }
+
 top    :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
        : importdecls                           { (reverse $1,[]) }
        | importdecls ';' cvtopdecls            { (reverse $1,$3) }
@@ -603,7 +618,7 @@ ty_decl :: { LTyClDecl RdrName }
                              (unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } }
 
           -- data/newtype family
-        | data_or_newtype 'family' tycl_hdr opt_kind_sig
+        | 'data' 'family' tycl_hdr opt_kind_sig
                {% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
                       ; checkTyVars tparms            -- no type pattern
                      ; unless (null (unLoc ctxt)) $  -- and no context
@@ -611,8 +626,7 @@ ty_decl :: { LTyClDecl RdrName }
                            "A family declaration cannot have a context"
                      ; return $
                          L (comb3 $1 $2 $4)
-                           (TyFamily (DataFamily (unLoc $1)) tc tvs 
-                                     (unLoc $4)) } }
+                           (TyFamily DataFamily tc tvs (unLoc $4)) } }
 
           -- data/newtype instance declaration
        | data_or_newtype 'instance' tycl_hdr constrs deriving
@@ -667,7 +681,7 @@ at_decl_cls :: { LTyClDecl RdrName }
                       } }
 
           -- data/newtype family declaration
-        | data_or_newtype tycl_hdr opt_kind_sig
+        | 'data' tycl_hdr opt_kind_sig
                {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
                       ; checkTyVars tparms            -- no type pattern
                      ; unless (null (unLoc ctxt)) $  -- and no context
@@ -675,8 +689,7 @@ at_decl_cls :: { LTyClDecl RdrName }
                            "A family declaration cannot have a context"
                      ; return $
                          L (comb3 $1 $2 $3)
-                           (TyFamily (DataFamily (unLoc $1)) tc tvs
-                                     (unLoc $3)) 
+                           (TyFamily DataFamily tc tvs (unLoc $3)) 
                       } }
 
 -- Associate type instances
@@ -1309,7 +1322,7 @@ aexp      :: { LHsExpr RdrName }
 
 aexp1  :: { LHsExpr RdrName }
         : aexp1 '{' fbinds '}'         {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) 
-                                                       (reverse $3);
+                                                       $3;
                                        return (LL r) }}
        | aexp2                 { $1 }
 
@@ -1325,6 +1338,9 @@ aexp2     :: { LHsExpr RdrName }
        : ipvar                         { L1 (HsIPVar $! unLoc $1) }
        | qcname                        { L1 (HsVar   $! unLoc $1) }
        | literal                       { L1 (HsLit   $! unLoc $1) }
+-- This will enable overloaded strings permanently.  Normally the renamer turns HsString
+-- into HsOverLit when -foverloaded-strings is on.
+--     | STRING                        { L1 (HsOverLit $! mkHsIsString (getSTRING $1)) }
        | INTEGER                       { L1 (HsOverLit $! mkHsIntegral (getINTEGER $1)) }
        | RATIONAL                      { L1 (HsOverLit $! mkHsFractional (getRATIONAL $1)) }
        | '(' exp ')'                   { LL (HsPar $2) }
@@ -1349,8 +1365,9 @@ aexp2     :: { LHsExpr RdrName }
        | '[|' exp '|]'         { LL $ HsBracket (ExpBr $2) }                       
        | '[t|' ctype '|]'      { LL $ HsBracket (TypBr $2) }                       
        | '[p|' infixexp '|]'   {% checkPattern $2 >>= \p ->
-                                          return (LL $ HsBracket (PatBr p)) }
-       | '[d|' cvtopbody '|]'  { LL $ HsBracket (DecBr (mkGroup $2)) }
+                                       return (LL $ HsBracket (PatBr p)) }
+       | '[d|' cvtopbody '|]'  {% checkDecBrGroup $2 >>= \g -> 
+                                       return (LL $ HsBracket (DecBr g)) }
 
        -- arrow notation extension
        | '(|' aexp2 cmdargs '|)'       { LL $ HsArrForm $2 Nothing (reverse $3) }
@@ -1431,12 +1448,12 @@ quals :: { Located [LStmt RdrName] }
 
 parr :: { LHsExpr RdrName }
        :                               { noLoc (ExplicitPArr placeHolderType []) }
-       | exp                           { L1 $ ExplicitPArr placeHolderType [$1] }
+       | texp                          { L1 $ ExplicitPArr placeHolderType [$1] }
        | lexps                         { L1 $ ExplicitPArr placeHolderType 
                                                       (reverse (unLoc $1)) }
-       | exp '..' exp                  { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) }
-       | exp ',' exp '..' exp          { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) }
-       | exp pquals                    { sL (comb2 $1 $>) $ mkHsDo PArrComp (reverse (unLoc $2)) $1 }
+       | texp '..' exp                 { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) }
+       | texp ',' exp '..' exp         { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) }
+       | texp pquals                   { sL (comb2 $1 $>) $ mkHsDo PArrComp (reverse (unLoc $2)) $1 }
 
 -- We are reusing `lexps' and `pquals' from the list case.
 
@@ -1532,10 +1549,10 @@ qual  :: { LStmt RdrName }
 -- Record Field Update/Construction
 
 fbinds         :: { HsRecordBinds RdrName }
-       : fbinds1                       { $1 }
-       | {- empty -}                   { [] }
+       : fbinds1                       { HsRecordBinds (reverse $1) }
+       | {- empty -}                   { HsRecordBinds [] }
 
-fbinds1        :: { HsRecordBinds RdrName }
+fbinds1        :: { [(Located id, LHsExpr id)] }
        : fbinds1 ',' fbind             { $3 : $1 }
        | fbind                         { [$1] }
   
@@ -1776,7 +1793,7 @@ consym :: { Located RdrName }
 
 literal :: { Located HsLit }
        : CHAR                  { L1 $ HsChar       $ getCHAR $1 }
-       | STRING                { L1 $ HsString     $ getSTRING $1 }
+       | STRING                { L1 $ HsString     $ getSTRING $1 }
        | PRIMINTEGER           { L1 $ HsIntPrim    $ getPRIMINTEGER $1 }
        | PRIMCHAR              { L1 $ HsCharPrim   $ getPRIMCHAR $1 }
        | PRIMSTRING            { L1 $ HsStringPrim $ getPRIMSTRING $1 }