[project @ 2004-05-06 12:26:13 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..5cd9be4 100644 (file)
--- a/ghc/compiler/parser/Parser.y.pp
+++ b/ghc/compiler/parser/Parser.y.pp
@@ -8,7 +8,7 @@
 -- ---------------------------------------------------------------------------
 
 {
-module Parser ( parseModule, parseStmt, parseIdentifier, parseIface ) where
+module Parser ( parseModule, parseStmt, parseIdentifier, parseIface, parseType ) where
 
 #define INCLUDE #include 
 INCLUDE "HsVersions.h"
@@ -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
 }
 
 {-
@@ -263,6 +263,7 @@ TH_TY_QUOTE { L _ ITtyQuote       }      -- ''T
 %name parseStmt   maybe_stmt
 %name parseIdentifier  identifier
 %name parseIface iface
+%name parseType ctype
 %tokentype { Located Token }
 %%
 
@@ -327,10 +328,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 +485,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 +724,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) }
@@ -751,7 +754,7 @@ context :: { LHsContext RdrName }
        : btype                         {% checkContext $1 }
 
 type :: { LHsType RdrName }
-       : ipvar '::' gentype            { LL (HsPredTy (LL $ HsIParam (unLoc $1) $3)) }
+       : ipvar '::' gentype            { LL (HsPredTy (HsIParam (unLoc $1) $3)) }
        | gentype                       { $1 }
 
 gentype :: { LHsType RdrName }
@@ -783,6 +786,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 +899,17 @@ strict_mark :: { Located HsBang }
        : '!'                           { L1 HsStrict }
        | '{-# UNPACK' '#-}' '!'        { LL HsUnbox }
 
-deriving :: { Located (Maybe (LHsContext RdrName)) }
-       : {- empty -}                   { noLoc Nothing }
-       | 'deriving' context            { LL (Just $2) }
+-- We allow the odd-looking 'inst_type' in a deriving clause, so that
+-- we can do deriving( forall a. C [a] ) in a newtype (GHC extension).
+-- The 'C [a]' part is converted to an HsPredTy by checkInstType
+-- We don't allow a context, but that's sorted out by the type checker.
+deriving :: { Located (Maybe [LHsType RdrName]) }
+       : {- empty -}                           { noLoc Nothing }
+       | 'deriving' qtycon     {% do { let { L loc tv = $2 }
+                                     ; p <- checkInstType (L loc (HsTyVar tv))
+                                     ; return (LL (Just [p])) } }
+       | 'deriving' '(' ')'                    { LL (Just []) }
+       | 'deriving' '(' inst_types1 ')'        { LL (Just $3) }
              -- Glasgow extension: allow partial 
              -- applications in derivings
 
@@ -951,7 +966,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 +1066,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 +1092,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 }