projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2005-03-10 08:56:35 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 e8144a6..9378f76 100644 (file)
--- a/ghc/compiler/parser/Parser.y.pp
+++ b/ghc/compiler/parser/Parser.y.pp
@@ -8,14 +8,15 @@
 -- ---------------------------------------------------------------------------
 
 {
 -- ---------------------------------------------------------------------------
 
 {
-module Parser ( parseModule, parseStmt, parseIdentifier, parseIface, parseType ) where
+module Parser ( parseModule, parseStmt, parseIdentifier, parseType,
+               parseHeader ) where
 
 #define INCLUDE #include 
 INCLUDE "HsVersions.h"
 
 import HsSyn
 import RdrHsSyn
 
 #define INCLUDE #include 
 INCLUDE "HsVersions.h"
 
 import HsSyn
 import RdrHsSyn
-import HscTypes                ( ModIface, IsBootInterface, DeprecTxt )
+import HscTypes                ( IsBootInterface, DeprecTxt )
 import Lexer
 import RdrName
 import TysWiredIn      ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon,
 import Lexer
 import RdrName
 import TysWiredIn      ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon,
@@ -35,7 +36,6 @@ import Type           ( Kind, mkArrowKind, liftedTypeKind )
 import BasicTypes      ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
                          Activation(..) )
 import OrdList
 import BasicTypes      ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
                          Activation(..) )
 import OrdList
-import Bag             ( emptyBag )
 import Panic
 
 import FastString
 import Panic
 
 import FastString
@@ -46,36 +46,49 @@ import GLAEXTS
 
 {-
 -----------------------------------------------------------------------------
 
 {-
 -----------------------------------------------------------------------------
-Conflicts: 33 shift/reduce, [SDM 19/9/2002]
+Conflicts: 36 shift/reduce (1.25)
 
 
-10 for abiguity in 'if x then y else z + 1'            [State 136]
+10 for abiguity in 'if x then y else z + 1'            [State 178]
        (shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
        10 because op might be: : - ! * . `x` VARSYM CONSYM QVARSYM QCONSYM
 
        (shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
        10 because op might be: : - ! * . `x` VARSYM CONSYM QVARSYM QCONSYM
 
-1 for ambiguity in 'if x then y else z with ?x=3'      [State 136]
-       (shift parses as 'if x then y else (z with ?x=3)'
-
-1 for ambiguity in 'if x then y else z :: T'           [State 136]
+1 for ambiguity in 'if x then y else z :: T'           [State 178]
        (shift parses as 'if x then y else (z :: T)', as per longest-parse rule)
 
        (shift parses as 'if x then y else (z :: T)', as per longest-parse rule)
 
-4 for ambiguity in 'if x then y else z -< e'
+4 for ambiguity in 'if x then y else z -< e'           [State 178]
        (shift parses as 'if x then y else (z -< T)', as per longest-parse rule)
        (shift parses as 'if x then y else (z -< T)', as per longest-parse rule)
+       There are four such operators: -<, >-, -<<, >>-
+
+
+2 for ambiguity in 'case v of { x :: T -> T ... } '    [States 11, 253]
+       Which of these two is intended?
+         case v of
+           (x::T) -> T         -- Rhs is T
+    or
+         case v of
+           (x::T -> T) -> ..   -- Rhs is ...
 
 
-8 for ambiguity in 'e :: a `b` c'.  Does this mean     [States 160,246]
+10 for ambiguity in 'e :: a `b` c'.  Does this mean    [States 11, 253]
        (e::a) `b` c, or 
        (e :: (a `b` c))
        (e::a) `b` c, or 
        (e :: (a `b` c))
+    As well as `b` we can have !, VARSYM, QCONSYM, and CONSYM, hence 5 cases
+    Same duplication between states 11 and 253 as the previous case
 
 
-1 for ambiguity in 'let ?x ...'                                [State 268]
+1 for ambiguity in 'let ?x ...'                                [State 329]
        the parser can't tell whether the ?x is the lhs of a normal binding or
        an implicit binding.  Fortunately resolving as shift gives it the only
        sensible meaning, namely the lhs of an implicit binding.
 
        the parser can't tell whether the ?x is the lhs of a normal binding or
        an implicit binding.  Fortunately resolving as shift gives it the only
        sensible meaning, namely the lhs of an implicit binding.
 
-1 for ambiguity in '{-# RULES "name" [ ... #-}         [State 332]
+1 for ambiguity in '{-# RULES "name" [ ... #-}         [State 382]
        we don't know whether the '[' starts the activation or not: it
        might be the start of the declaration with the activation being
        empty.  --SDM 1/4/2002
 
        we don't know whether the '[' starts the activation or not: it
        might be the start of the declaration with the activation being
        empty.  --SDM 1/4/2002
 
-1 for ambiguity in '{-# RULES "name" forall = ... #-}'         [State 394]
+6 for conflicts between `fdecl' and `fdeclDEPRECATED',         [States 393,394]
+       which are resolved correctly, and moreover, 
+       should go away when `fdeclDEPRECATED' is removed.
+
+1 for ambiguity in '{-# RULES "name" forall = ... #-}'         [State 474]
        since 'forall' is a valid variable name, we don't know whether
        to treat a forall on the input as the beginning of a quantifier
        or the beginning of the rule itself.  Resolving to shift means
        since 'forall' is a valid variable name, we don't know whether
        to treat a forall on the input as the beginning of a quantifier
        or the beginning of the rule itself.  Resolving to shift means
@@ -83,10 +96,6 @@ Conflicts: 33 shift/reduce, [SDM 19/9/2002]
        This saves explicitly defining a grammar for the rule lhs that
        doesn't include 'forall'.
 
        This saves explicitly defining a grammar for the rule lhs that
        doesn't include 'forall'.
 
-6 for conflicts between `fdecl' and `fdeclDEPRECATED',         [States 384,385]
-       which are resolved correctly, and moreover, 
-       should go away when `fdeclDEPRECATED' is removed.
-
 -- ---------------------------------------------------------------------------
 -- Adding location info
 
 -- ---------------------------------------------------------------------------
 -- Adding location info
 
@@ -265,8 +274,8 @@ TH_TY_QUOTE { L _ ITtyQuote       }      -- ''T
 %name parseModule module
 %name parseStmt   maybe_stmt
 %name parseIdentifier  identifier
 %name parseModule module
 %name parseStmt   maybe_stmt
 %name parseIdentifier  identifier
-%name parseIface iface
 %name parseType ctype
 %name parseType ctype
+%partial parseHeader header
 %tokentype { Located Token }
 %%
 
 %tokentype { Located Token }
 %%
 
@@ -309,36 +318,19 @@ cvtopdecls :: { [LHsDecl RdrName] }
        : topdecls                              { cvTopDecls $1 }
 
 -----------------------------------------------------------------------------
        : topdecls                              { cvTopDecls $1 }
 
 -----------------------------------------------------------------------------
--- Interfaces (.hi-boot files)
-
-iface   :: { ModIface }
-       : 'module' modid 'where' ifacebody  { mkBootIface (unLoc $2) $4 }
+-- Module declaration & imports only
 
 
-ifacebody :: { [HsDecl RdrName] }
-       :  '{'            ifacedecls '}'                { $2 }
-       |      vocurly    ifacedecls close              { $2 }
-
-ifacedecls :: { [HsDecl RdrName] }
-       : ifacedecl ';' ifacedecls      { $1 : $3 }
-       | ';' ifacedecls                { $2 }
-       | ifacedecl                     { [$1] }
-       | {- empty -}                   { [] }
+header         :: { Located (HsModule RdrName) }
+       : 'module' modid maybemoddeprec maybeexports 'where' header_body
+               {% fileSrcSpan >>= \ loc ->
+                  return (L loc (HsModule (Just $2) $4 $6 [] $3)) }
+       | missing_module_keyword importdecls
+               {% fileSrcSpan >>= \ loc ->
+                  return (L loc (HsModule Nothing Nothing $2 [] Nothing)) }
 
 
-ifacedecl :: { HsDecl RdrName }
-       : var '::' sigtype      
-                { SigD (Sig $1 $3) }
-       | 'type' syn_hdr '=' ctype      
-               { let (tc,tvs) = $2 in TyClD (TySynonym tc tvs $4) }
-       | 'data' tycl_hdr constrs       -- No deriving in hi-boot
-               { TyClD (mkTyData DataType $2 Nothing (reverse (unLoc $3)) Nothing) }
-        | 'data' tycl_hdr 'where' gadt_constrlist      
-               { TyClD (mkTyData DataType $2 Nothing (reverse (unLoc $4)) Nothing) }
-       | 'newtype' tycl_hdr            -- Constructor is optional
-               { TyClD (mkTyData NewType $2 Nothing [] Nothing) }
-       | 'newtype' tycl_hdr '=' newconstr
-               { TyClD (mkTyData NewType $2 Nothing [$4] Nothing) }
-       | 'class' tycl_hdr fds
-               { TyClD (mkClassDecl (unLoc $2) (unLoc $3) [] emptyBag) }
+header_body :: { [LImportDecl RdrName] }
+       :  '{'            importdecls           { $2 }
+       |      vocurly    importdecls           { $2 }
 
 -----------------------------------------------------------------------------
 -- The Export List
 
 -----------------------------------------------------------------------------
 -- The Export List
@@ -444,15 +436,20 @@ topdecl :: { OrdList (LHsDecl RdrName) }
        | decl                                  { unLoc $1 }
 
 tycl_decl :: { LTyClDecl RdrName }
        | decl                                  { unLoc $1 }
 
 tycl_decl :: { LTyClDecl RdrName }
-       : 'type' syn_hdr '=' ctype      
-               -- Note ctype, not sigtype.
+       : 'type' type '=' ctype 
+               -- Note type on the left of the '='; this allows
+               -- infix type constructors to be declared
+               -- 
+               -- Note ctype, not sigtype, on the right
                -- We allow an explicit for-all but we don't insert one
                -- in   type Foo a = (b,b)
                -- Instead we just say b is out of scope
                -- We allow an explicit for-all but we don't insert one
                -- in   type Foo a = (b,b)
                -- Instead we just say b is out of scope
-               { LL $ let (tc,tvs) = $2 in TySynonym tc tvs $4 }
+               {% do { (tc,tvs) <- checkSynHdr $2
+                     ; return (LL (TySynonym tc tvs $4)) } }
 
        | 'data' tycl_hdr constrs deriving
 
        | 'data' tycl_hdr constrs deriving
-               { L (comb4 $1 $2 $3 $4)
+               { 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)) }
 
         | 'data' tycl_hdr opt_kind_sig 'where' gadt_constrlist -- No deriving for GADTs
                    (mkTyData DataType $2 Nothing (reverse (unLoc $3)) (unLoc $4)) }
 
         | 'data' tycl_hdr opt_kind_sig 'where' gadt_constrlist -- No deriving for GADTs
@@ -474,12 +471,6 @@ opt_kind_sig :: { Maybe Kind }
        :                               { Nothing }
        | '::' kind                     { Just $2 }
 
        :                               { Nothing }
        | '::' kind                     { Just $2 }
 
-syn_hdr :: { (Located RdrName, [LHsTyVarBndr RdrName]) }
-               -- We don't retain the syntax of an infix
-               -- type synonym declaration. Oh well.
-       : tycon tv_bndrs                { ($1, $2) }
-       | tv_bndr tyconop tv_bndr       { ($2, [$1,$3]) }
-
 -- tycl_hdr parses the header of a type or class decl,
 -- which takes the form
 --     T a b
 -- tycl_hdr parses the header of a type or class decl,
 -- which takes the form
 --     T a b
@@ -487,7 +478,7 @@ syn_hdr :: { (Located RdrName, [LHsTyVarBndr RdrName]) }
 --     (Eq a, Ord b) => T a b
 -- Rather a lot of inlining here, else we get reduce/reduce errors
 tycl_hdr :: { Located (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName]) }
 --     (Eq a, Ord b) => T a b
 -- Rather a lot of inlining here, else we get reduce/reduce errors
 tycl_hdr :: { Located (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName]) }
-       : context '=>' type             {% checkTyClHdr $1 $3 >>= return.LL }
+       : context '=>' type             {% checkTyClHdr $1         $3 >>= return.LL }
        | type                          {% checkTyClHdr (noLoc []) $1 >>= return.L1 }
 
 -----------------------------------------------------------------------------
        | type                          {% checkTyClHdr (noLoc []) $1 >>= return.L1 }
 
 -----------------------------------------------------------------------------
@@ -775,7 +766,7 @@ type :: { LHsType RdrName }
 gentype :: { LHsType RdrName }
         : btype                         { $1 }
         | btype qtyconop gentype        { LL $ HsOpTy $1 $2 $3 }
 gentype :: { LHsType RdrName }
         : btype                         { $1 }
         | btype qtyconop gentype        { LL $ HsOpTy $1 $2 $3 }
-        | btype  '`' tyvar '`' gentype  { LL $ HsOpTy $1 $3 $5 }
+        | btype tyvarop  gentype       { LL $ HsOpTy $1 $2 $3 }
        | btype '->' gentype            { LL $ HsFunTy $1 $3 }
 
 btype :: { LHsType RdrName }
        | btype '->' gentype            { LL $ HsFunTy $1 $3 }
 
 btype :: { LHsType RdrName }
@@ -864,6 +855,7 @@ gadt_constrlist :: { Located [LConDecl RdrName] }
 
 gadt_constrs :: { Located [LConDecl RdrName] }
         : gadt_constrs ';' gadt_constr  { LL ($3 : unLoc $1) }
 
 gadt_constrs :: { Located [LConDecl RdrName] }
         : gadt_constrs ';' gadt_constr  { LL ($3 : unLoc $1) }
+        | gadt_constrs ';'             { $1 }
         | gadt_constr                   { L1 [$1] } 
 
 gadt_constr :: { LConDecl RdrName }
         | gadt_constr                   { L1 [$1] } 
 
 gadt_constr :: { LConDecl RdrName }
@@ -1365,10 +1357,6 @@ qtyconop :: { Located RdrName }  -- Qualified or unqualified
        : qtyconsym                     { $1 }
        | '`' qtycon '`'                { LL (unLoc $2) }
 
        : qtyconsym                     { $1 }
        | '`' qtycon '`'                { LL (unLoc $2) }
 
-tyconop        :: { Located RdrName }  -- Unqualified
-       : tyconsym                      { $1 }
-       | '`' tycon '`'                 { LL (unLoc $2) }
-
 qtycon :: { Located RdrName }  -- Qualified or unqualified
        : QCONID                        { L1 $! mkQual tcClsName (getQCONID $1) }
        | tycon                         { $1 }
 qtycon :: { Located RdrName }  -- Qualified or unqualified
        : QCONID                        { L1 $! mkQual tcClsName (getQCONID $1) }
        | tycon                         { $1 }
@@ -1416,13 +1404,27 @@ varid_no_unsafe :: { Located RdrName }
        | special_id            { L1 $! mkUnqual varName (unLoc $1) }
        | 'forall'              { L1 $! mkUnqual varName FSLIT("forall") }
 
        | special_id            { L1 $! mkUnqual varName (unLoc $1) }
        | 'forall'              { L1 $! mkUnqual varName FSLIT("forall") }
 
-tyvar  :: { Located RdrName }
+tyvar   :: { Located RdrName }
+tyvar   : tyvarid              { $1 }
+       | '(' tyvarsym ')'      { LL (unLoc $2) }
+
+tyvarop :: { Located RdrName }
+tyvarop : '`' tyvarid '`'      { LL (unLoc $2) }
+       | tyvarsym              { $1 }
+
+tyvarid        :: { Located RdrName }
        : VARID                 { L1 $! mkUnqual tvName (getVARID $1) }
        | special_id            { L1 $! mkUnqual tvName (unLoc $1) }
        | 'unsafe'              { L1 $! mkUnqual tvName FSLIT("unsafe") }
        | 'safe'                { L1 $! mkUnqual tvName FSLIT("safe") }
        | 'threadsafe'          { L1 $! mkUnqual tvName FSLIT("threadsafe") }
 
        : VARID                 { L1 $! mkUnqual tvName (getVARID $1) }
        | special_id            { L1 $! mkUnqual tvName (unLoc $1) }
        | 'unsafe'              { L1 $! mkUnqual tvName FSLIT("unsafe") }
        | 'safe'                { L1 $! mkUnqual tvName FSLIT("safe") }
        | 'threadsafe'          { L1 $! mkUnqual tvName FSLIT("threadsafe") }
 
+tyvarsym :: { Located RdrName }
+-- Does not include "!", because that is used for strictness marks
+--              or ".", because that separates the quantified type vars from the rest
+--              or "*", because that's used for kinds
+tyvarsym : VARSYM              { L1 $! mkUnqual tvName (getVARSYM $1) }
+
 -- 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
 -- 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
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)