[project @ 2006-01-06 16:30:17 by simonmar]

[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 e204d11..b4acb89 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 }
@@ -531,11 +530,13 @@ rules     :: { OrdList (LHsDecl RdrName) }        -- Reversed
 
 rule   :: { LHsDecl RdrName }
        : STRING activation rule_forall infixexp '=' exp
-            { LL $ RuleD (HsRule (getSTRING $1) $2 $3 $4 $6) }
+            { LL $ RuleD (HsRule (getSTRING $1) 
+                                 ($2 `orElse` AlwaysActive) 
+                                 $3 $4 $6) }
 
-activation :: { Activation }           -- Omitted means AlwaysActive
-        : {- empty -}                           { AlwaysActive }
-        | explicit_activation                   { $1 }
+activation :: { Maybe Activation } 
+        : {- empty -}                           { Nothing }
+        | explicit_activation                   { Just $1 }
 
 explicit_activation :: { Activation }  -- In brackets
         : '[' INTEGER ']'              { ActiveAfter  (fromInteger (getINTEGER $2)) }
@@ -850,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 }
@@ -996,12 +992,12 @@ 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 (Inline $2 (getINLINE $1)))) }
+                               { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 (getINLINE $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 (Inline $2 (getSPEC_INLINE $1)))
+                               { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 (getSPEC_INLINE $1)))
                                            | t <- $5] }
        | '{-# SPECIALISE' 'instance' inst_type '#-}'
                                { LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
@@ -1473,7 +1469,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") }
@@ -1484,7 +1480,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("*") }