[project @ 2004-04-02 16:46:57 by simonpj]

[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 4dec2de..49eefb3 100644 (file)
--- a/ghc/compiler/parser/Parser.y.pp
+++ b/ghc/compiler/parser/Parser.y.pp
@@ -32,16 +32,16 @@ import Module
 import CmdLineOpts     ( opt_SccProfilingOn )
 import Type            ( Kind, mkArrowKind, liftedTypeKind )
 import BasicTypes      ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
-                         NewOrData(..), Activation(..) )
+                         Activation(..) )
 import OrdList
 import Bag             ( emptyBag )
 import Panic
 
-import GLAEXTS
 import CStrings                ( CLabelString )
 import FastString
 import Maybes          ( orElse )
 import Outputable
+import GLAEXTS
 }
 
 {-
@@ -327,10 +327,12 @@ ifacedecl :: { HsDecl RdrName }
                 { SigD (Sig $1 $3) }
        | 'type' syn_hdr '=' ctype      
                { let (tc,tvs) = $2 in TyClD (TySynonym tc tvs $4) }
-       | 'data' tycl_hdr
-               { TyClD (mkTyData DataType (unLoc $2) [] Nothing) }
-       | 'newtype' tycl_hdr
+       | 'data' tycl_hdr constrs       -- No deriving in hi-boot
+               { TyClD (mkTyData DataType (unLoc $2) (reverse (unLoc $3)) Nothing) }
+       | 'newtype' tycl_hdr            -- Constructor is optional
                { TyClD (mkTyData NewType (unLoc $2) [] Nothing) }
+       | 'newtype' tycl_hdr '=' newconstr
+               { TyClD (mkTyData NewType (unLoc $2) [$4] Nothing) }
        | 'class' tycl_hdr fds
                { TyClD (mkClassDecl (unLoc $2) (unLoc $3) [] emptyBag) }
 
@@ -482,7 +484,7 @@ tycl_hdr :: { Located (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrNam
 decls  :: { Located (OrdList (LHsDecl RdrName)) }      -- Reversed
        : decls ';' decl                { LL (unLoc $1 `appOL` unLoc $3) }
        | decls ';'                     { LL (unLoc $1) }
-       | decl                          { L1 (unLoc $1) }
+       | decl                          { $1 }
        | {- empty -}                   { noLoc nilOL }
 
 
@@ -721,9 +723,9 @@ opt_asig :: { Maybe (LHsType RdrName) }
        : {- empty -}                   { Nothing }
        | '::' atype                    { Just $2 }
 
-sigtypes :: { [LHsType RdrName] }
+sigtypes1 :: { [LHsType RdrName] }
        : sigtype                       { [ $1 ] }
-       | sigtypes ',' sigtype          { $3 : $1 }
+       | sigtype ',' sigtypes1         { $1 : $3 }
 
 sigtype :: { LHsType RdrName }
        : ctype                         { L1 (mkImplicitHsForAllTy (noLoc []) $1) }
@@ -783,6 +785,10 @@ atype :: { LHsType RdrName }
 inst_type :: { LHsType RdrName }
        : ctype                         {% checkInstType $1 }
 
+inst_types1 :: { [LHsType RdrName] }
+       : inst_type                     { [$1] }
+       | inst_type ',' inst_types1     { $1 : $3 }
+
 comma_types0  :: { [LHsType RdrName] }
        : comma_types1                  { $1 }
        | {- empty -}                   { [] }
@@ -892,9 +898,10 @@ strict_mark :: { Located HsBang }
        : '!'                           { L1 HsStrict }
        | '{-# UNPACK' '#-}' '!'        { LL HsUnbox }
 
-deriving :: { Located (Maybe (LHsContext RdrName)) }
-       : {- empty -}                   { noLoc Nothing }
-       | 'deriving' context            { LL (Just $2) }
+deriving :: { Located (Maybe [LHsType RdrName]) }
+       : {- empty -}                           { noLoc Nothing }
+       | 'deriving' '(' ')'                    { LL (Just []) }
+       | 'deriving' '(' inst_types1 ')'        { LL (Just $3) }
              -- Glasgow extension: allow partial 
              -- applications in derivings
 
@@ -951,7 +958,7 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
                                { LL $ unitOL (LL $ SigD (InlineSig True  $3 $2)) }
        | '{-# NOINLINE' inverse_activation qvar '#-}' 
                                { LL $ unitOL (LL $ SigD (InlineSig False $3 $2)) }
-       | '{-# SPECIALISE' qvar '::' sigtypes '#-}'
+       | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
                                { LL $ toOL [ LL $ SigD (SpecSig $2 t)
                                            | t <- $4] }
        | '{-# SPECIALISE' 'instance' inst_type '#-}'
@@ -1051,10 +1058,11 @@ aexp2   :: { LHsExpr RdrName }
        | '_'                           { L1 EWildPat }
        
        -- MetaHaskell Extension
-       | TH_ID_SPLICE          { L1 $ mkHsSplice 
+       | TH_ID_SPLICE          { L1 $ HsSpliceE (mkHsSplice 
                                        (L1 $ HsVar (mkUnqual varName 
-                                                       (getTH_ID_SPLICE $1))) } -- $x
-       | '$(' exp ')'          { LL $ mkHsSplice $2 }                            -- $( exp )
+                                                       (getTH_ID_SPLICE $1)))) } -- $x
+       | '$(' exp ')'          { LL $ HsSpliceE (mkHsSplice $2) }               -- $( exp )
+
        | 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)) }
@@ -1076,8 +1084,12 @@ acmd     :: { LHsCmdTop RdrName }
        : aexp2                 { L1 $ HsCmdTop $1 [] placeHolderType undefined }
 
 cvtopbody :: { [LHsDecl RdrName] }
-       :  '{'            cvtopdecls '}'                { $2 }
-       |      vocurly    cvtopdecls close              { $2 }
+       :  '{'            cvtopdecls0 '}'               { $2 }
+       |      vocurly    cvtopdecls0 close             { $2 }
+
+cvtopdecls0 :: { [LHsDecl RdrName] }
+       : {- empty -}           { [] }
+       | cvtopdecls            { $1 }
 
 texps :: { [LHsExpr RdrName] }
        : texps ',' exp                 { $3 : $1 }