projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2005-03-09 16:58:15 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 02a723a..4fa738a 100644 (file)
--- a/ghc/compiler/parser/Parser.y.pp
+++ b/ghc/compiler/parser/Parser.y.pp
@@ -8,36 +8,36 @@
 -- ---------------------------------------------------------------------------
 
 {
 -- ---------------------------------------------------------------------------
 
 {
-module Parser ( parseModule, parseStmt, parseIdentifier, parseIface ) 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,
                          listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR )
 import Type            ( funTyCon )
 import Lexer
 import RdrName
 import TysWiredIn      ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon,
                          listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR )
 import Type            ( funTyCon )
-import ForeignCall     ( Safety(..), CExportSpec(..), 
+import ForeignCall     ( Safety(..), CExportSpec(..), CLabelString,
                          CCallConv(..), CCallTarget(..), defaultCCallConv
                        )
 import OccName         ( UserFS, varName, dataName, tcClsName, tvName )
 import DataCon         ( DataCon, dataConName )
 import SrcLoc          ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
                          CCallConv(..), CCallTarget(..), defaultCCallConv
                        )
 import OccName         ( UserFS, varName, dataName, tcClsName, tvName )
 import DataCon         ( DataCon, dataConName )
 import SrcLoc          ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
-                         SrcSpan, combineLocs, mkGeneralSrcSpan, srcLocFile )
+                         SrcSpan, combineLocs, srcLocFile, 
+                         mkSrcLoc, mkSrcSpan )
 import Module
 import CmdLineOpts     ( opt_SccProfilingOn )
 import Type            ( Kind, mkArrowKind, liftedTypeKind )
 import BasicTypes      ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
 import Module
 import CmdLineOpts     ( opt_SccProfilingOn )
 import Type            ( Kind, mkArrowKind, liftedTypeKind )
 import BasicTypes      ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
-                         NewOrData(..), Activation(..) )
+                         Activation(..) )
 import OrdList
 import OrdList
-import Bag             ( emptyBag )
 import Panic
 
 import Panic
 
-import CStrings                ( CLabelString )
 import FastString
 import Maybes          ( orElse )
 import Outputable
 import FastString
 import Maybes          ( orElse )
 import Outputable
@@ -46,33 +46,49 @@ import GLAEXTS
 
 {-
 -----------------------------------------------------------------------------
 
 {-
 -----------------------------------------------------------------------------
-Conflicts: 29 shift/reduce, [SDM 19/9/2002]
+Conflicts: 34 shift/reduce (1.15)
 
 
-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)
 
-8 for ambiguity in 'e :: a `b` c'.  Does this mean     [States 160,246]
+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)
+       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 ...
+
+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
@@ -80,10 +96,6 @@ Conflicts: 29 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
 
@@ -262,7 +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
+%partial parseHeader header
 %tokentype { Located Token }
 %%
 
 %tokentype { Located Token }
 %%
 
@@ -279,9 +292,7 @@ TH_TY_QUOTE { L _ ITtyQuote       }      -- ''T
 module         :: { Located (HsModule RdrName) }
        : 'module' modid maybemoddeprec maybeexports 'where' body 
                {% fileSrcSpan >>= \ loc ->
 module         :: { Located (HsModule RdrName) }
        : 'module' modid maybemoddeprec maybeexports 'where' body 
                {% fileSrcSpan >>= \ loc ->
-                  return (L loc (HsModule (Just (L (getLoc $2) 
-                                       (mkHomeModule (unLoc $2))))
-                               $4 (fst $6) (snd $6) $3)) }
+                  return (L loc (HsModule (Just $2) $4 (fst $6) (snd $6) $3)) }
        | missing_module_keyword top close
                {% fileSrcSpan >>= \ loc ->
                   return (L loc (HsModule Nothing Nothing 
        | missing_module_keyword top close
                {% fileSrcSpan >>= \ loc ->
                   return (L loc (HsModule Nothing Nothing 
@@ -307,32 +318,19 @@ cvtopdecls :: { [LHsDecl RdrName] }
        : topdecls                              { cvTopDecls $1 }
 
 -----------------------------------------------------------------------------
        : topdecls                              { cvTopDecls $1 }
 
 -----------------------------------------------------------------------------
--- Interfaces (.hi-boot files)
+-- Module declaration & imports only
 
 
-iface   :: { ModIface }
-       : 'module' modid 'where' ifacebody  { mkBootIface (unLoc $2) $4 }
-
-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
-               { TyClD (mkTyData DataType (unLoc $2) [] Nothing) }
-       | 'newtype' tycl_hdr
-               { TyClD (mkTyData NewType (unLoc $2) [] 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
@@ -389,7 +387,7 @@ optqualified :: { Bool }
        : 'qualified'                           { True  }
        | {- empty -}                           { False }
 
        : 'qualified'                           { True  }
        | {- empty -}                           { False }
 
-maybeas :: { Located (Maybe ModuleName) }
+maybeas :: { Located (Maybe Module) }
        : 'as' modid                            { LL (Just (unLoc $2)) }
        | {- empty -}                           { noLoc Nothing }
 
        : 'as' modid                            { LL (Just (unLoc $2)) }
        | {- empty -}                           { noLoc Nothing }
 
@@ -438,20 +436,29 @@ 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)
-                   (mkTyData DataType (unLoc $2) (reverse (unLoc $3)) (unLoc $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
+               { L (comb4 $1 $2 $4 $5)
+                   (mkTyData DataType $2 $3 (reverse (unLoc $5)) Nothing) }
 
        | 'newtype' tycl_hdr '=' newconstr deriving
                { L (comb3 $1 $4 $5)
 
        | 'newtype' tycl_hdr '=' newconstr deriving
                { L (comb3 $1 $4 $5)
-                   (mkTyData NewType (unLoc $2) [$4] (unLoc $5)) }
+                   (mkTyData NewType $2 Nothing [$4] (unLoc $5)) }
 
        | 'class' tycl_hdr fds where
                { let 
 
        | 'class' tycl_hdr fds where
                { let 
@@ -460,11 +467,9 @@ tycl_decl :: { LTyClDecl RdrName }
                  L (comb4 $1 $2 $3 $4) (mkClassDecl (unLoc $2) (unLoc $3) sigs 
                                          binds) }
 
                  L (comb4 $1 $2 $3 $4) (mkClassDecl (unLoc $2) (unLoc $3) sigs 
                                          binds) }
 
-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]) }
+opt_kind_sig :: { Maybe Kind }
+       :                               { Nothing }
+       | '::' kind                     { Just $2 }
 
 -- tycl_hdr parses the header of a type or class decl,
 -- which takes the form
 
 -- tycl_hdr parses the header of a type or class decl,
 -- which takes the form
@@ -473,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 }
 
 -----------------------------------------------------------------------------
@@ -482,7 +487,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) }
 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 }
 
 
        | {- empty -}                   { noLoc nilOL }
 
 
@@ -721,9 +726,9 @@ opt_asig :: { Maybe (LHsType RdrName) }
        : {- empty -}                   { Nothing }
        | '::' atype                    { Just $2 }
 
        : {- empty -}                   { Nothing }
        | '::' atype                    { Just $2 }
 
-sigtypes :: { [LHsType RdrName] }
+sigtypes1 :: { [LHsType RdrName] }
        : sigtype                       { [ $1 ] }
        : sigtype                       { [ $1 ] }
-       | sigtypes ',' sigtype          { $3 : $1 }
+       | sigtype ',' sigtypes1         { $1 : $3 }
 
 sigtype :: { LHsType RdrName }
        : ctype                         { L1 (mkImplicitHsForAllTy (noLoc []) $1) }
 
 sigtype :: { LHsType RdrName }
        : ctype                         { L1 (mkImplicitHsForAllTy (noLoc []) $1) }
@@ -736,6 +741,10 @@ sig_vars :: { Located [Located RdrName] }
 -----------------------------------------------------------------------------
 -- Types
 
 -----------------------------------------------------------------------------
 -- Types
 
+strict_mark :: { Located HsBang }
+       : '!'                           { L1 HsStrict }
+       | '{-# UNPACK' '#-}' '!'        { LL HsUnbox }
+
 -- A ctype is a for-all type
 ctype  :: { LHsType RdrName }
        : 'forall' tv_bndrs '.' ctype   { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 }
 -- A ctype is a for-all type
 ctype  :: { LHsType RdrName }
        : 'forall' tv_bndrs '.' ctype   { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 }
@@ -751,13 +760,13 @@ context :: { LHsContext RdrName }
        : btype                         {% checkContext $1 }
 
 type :: { LHsType 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 }
         : btype                         { $1 }
         | btype qtyconop gentype        { LL $ HsOpTy $1 $2 $3 }
        | gentype                       { $1 }
 
 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 }
@@ -766,7 +775,8 @@ btype :: { LHsType RdrName }
 
 atype :: { LHsType RdrName }
        : gtycon                        { L1 (HsTyVar (unLoc $1)) }
 
 atype :: { LHsType RdrName }
        : gtycon                        { L1 (HsTyVar (unLoc $1)) }
-       | tyvar                         { L1 (HsTyVar (unLoc $1)) }
+       | tyvarid                       { L1 (HsTyVar (unLoc $1)) }
+       | strict_mark atype             { LL (HsBangTy (unLoc $1) $2) }
        | '(' type ',' comma_types1 ')' { LL $ HsTupleTy Boxed  ($2:$4) }
        | '(#' comma_types1 '#)'        { LL $ HsTupleTy Unboxed $2     }
        | '[' type ']'                  { LL $ HsListTy  $2 }
        | '(' type ',' comma_types1 ')' { LL $ HsTupleTy Boxed  ($2:$4) }
        | '(#' comma_types1 '#)'        { LL $ HsTupleTy Unboxed $2     }
        | '[' type ']'                  { LL $ HsListTy  $2 }
@@ -781,7 +791,11 @@ atype :: { LHsType RdrName }
 -- It's kept as a single type, with a MonoDictTy at the right
 -- hand corner, for convenience.
 inst_type :: { LHsType RdrName }
 -- It's kept as a single type, with a MonoDictTy at the right
 -- hand corner, for convenience.
 inst_type :: { LHsType RdrName }
-       : ctype                         {% checkInstType $1 }
+       : sigtype                       {% checkInstType $1 }
+
+inst_types1 :: { [LHsType RdrName] }
+       : inst_type                     { [$1] }
+       | inst_type ',' inst_types1     { $1 : $3 }
 
 comma_types0  :: { [LHsType RdrName] }
        : comma_types1                  { $1 }
 
 comma_types0  :: { [LHsType RdrName] }
        : comma_types1                  { $1 }
@@ -831,11 +845,22 @@ akind     :: { Kind }
 -- Datatype declarations
 
 newconstr :: { LConDecl RdrName }
 -- Datatype declarations
 
 newconstr :: { LConDecl RdrName }
-       : conid atype   { LL $ ConDecl $1 [] (noLoc []) 
-                               (PrefixCon [(unbangedType $2)]) }
+       : conid atype   { LL $ ConDecl $1 [] (noLoc []) (PrefixCon [$2]) }
        | conid '{' var '::' ctype '}'
        | conid '{' var '::' ctype '}'
-                       { LL $ ConDecl $1 [] (noLoc []) 
-                                 (RecCon [($3, (unbangedType $5))]) }
+                       { LL $ ConDecl $1 [] (noLoc []) (RecCon [($3, $5)]) }
+
+gadt_constrlist :: { Located [LConDecl RdrName] }
+       : '{'            gadt_constrs '}'       { LL (unLoc $2) }
+       |     vocurly    gadt_constrs close     { $2 }
+
+gadt_constrs :: { Located [LConDecl RdrName] }
+        : gadt_constrs ';' gadt_constr  { LL ($3 : unLoc $1) }
+        | gadt_constrs ';'             { $1 }
+        | gadt_constr                   { L1 [$1] } 
+
+gadt_constr :: { LConDecl RdrName }
+        : qcon '::' sigtype
+              { LL (GadtDecl $1 $3) } 
 
 constrs :: { Located [LConDecl RdrName] }
         : {- empty; a GHC extension -}  { noLoc [] }
 
 constrs :: { Located [LConDecl RdrName] }
         : {- empty; a GHC extension -}  { noLoc [] }
@@ -858,43 +883,36 @@ forall :: { Located [LHsTyVarBndr RdrName] }
        | {- empty -}                   { noLoc [] }
 
 constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) }
        | {- empty -}                   { noLoc [] }
 
 constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) }
+-- We parse the constructor declaration 
+--     C t1 t2
+-- as a btype (treating C as a type constructor) and then convert C to be
+-- a data constructor.  Reason: it might continue like this:
+--     C t1 t2 %: D Int
+-- in which case C really would be a type constructor.  We can't resolve this
+-- ambiguity till we come across the constructor oprerator :% (or not, more usually)
        : btype                         {% mkPrefixCon $1 [] >>= return.LL }
        : btype                         {% mkPrefixCon $1 [] >>= return.LL }
-       | btype bang_atype satypes      {% do { r <- mkPrefixCon $1 ($2 : unLoc $3);
-                                               return (L (comb3 $1 $2 $3) r) } }
        | oqtycon '{' '}'               {% mkRecCon $1 [] >>= return.LL }
        | oqtycon '{' fielddecls '}'    {% mkRecCon $1 $3 >>= return.LL }
        | oqtycon '{' '}'               {% mkRecCon $1 [] >>= return.LL }
        | oqtycon '{' fielddecls '}'    {% mkRecCon $1 $3 >>= return.LL }
-       | sbtype conop sbtype           { LL ($2, InfixCon $1 $3) }
-
-bang_atype :: { LBangType RdrName }
-       : strict_mark atype             { LL (BangType (unLoc $1) $2) }
-
-satypes        :: { Located [LBangType RdrName] }
-       : atype satypes                 { LL (unbangedType $1 : unLoc $2) }
-       | bang_atype satypes            { LL ($1 : unLoc $2) }
-       | {- empty -}                   { noLoc [] }
-
-sbtype :: { LBangType RdrName }
-       : btype                         { unbangedType $1 }
-       | strict_mark atype             { LL (BangType (unLoc $1) $2) }
+       | btype conop btype             { LL ($2, InfixCon $1 $3) }
 
 fielddecls :: { [([Located RdrName], LBangType RdrName)] }
        : fielddecl ',' fielddecls      { unLoc $1 : $3 }
        | fielddecl                     { [unLoc $1] }
 
 fielddecl :: { Located ([Located RdrName], LBangType RdrName) }
 
 fielddecls :: { [([Located RdrName], LBangType RdrName)] }
        : fielddecl ',' fielddecls      { unLoc $1 : $3 }
        | fielddecl                     { [unLoc $1] }
 
 fielddecl :: { Located ([Located RdrName], LBangType RdrName) }
-       : sig_vars '::' stype           { LL (reverse (unLoc $1), $3) }
-
-stype :: { LBangType RdrName }
-       : ctype                         { unbangedType $1 }
-       | strict_mark atype             { LL (BangType (unLoc $1) $2) }
-
-strict_mark :: { Located HsBang }
-       : '!'                           { L1 HsStrict }
-       | '{-# UNPACK' '#-}' '!'        { LL HsUnbox }
-
-deriving :: { Located (Maybe (LHsContext RdrName)) }
-       : {- empty -}                   { noLoc Nothing }
-       | 'deriving' context            { LL (Just $2) }
+       : sig_vars '::' ctype           { LL (reverse (unLoc $1), $3) }
+
+-- 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
 
              -- Glasgow extension: allow partial 
              -- applications in derivings
 
@@ -923,12 +941,12 @@ deriving :: { Located (Maybe (LHsContext RdrName)) }
 
 decl   :: { Located (OrdList (LHsDecl RdrName)) }
        : sigdecl                       { $1 }
 
 decl   :: { Located (OrdList (LHsDecl RdrName)) }
        : sigdecl                       { $1 }
-       | infixexp opt_sig rhs          {% do { r <- checkValDef $1 $2 (unLoc $3);
+       | infixexp opt_sig rhs          {% do { r <- checkValDef $1 $2 $3;
                                                return (LL $ unitOL (LL $ ValD r)) } }
 
 rhs    :: { Located (GRHSs RdrName) }
                                                return (LL $ unitOL (LL $ ValD r)) } }
 
 rhs    :: { Located (GRHSs RdrName) }
-       : '=' exp wherebinds    { L (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) placeHolderType }
-       | gdrhs wherebinds      { LL $ GRHSs (reverse (unLoc $1)) (unLoc $2) placeHolderType }
+       : '=' exp wherebinds    { L (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) }
+       | gdrhs wherebinds      { LL $ GRHSs (reverse (unLoc $1)) (unLoc $2) }
 
 gdrhs :: { Located [LGRHS RdrName] }
        : gdrhs gdrh            { LL ($2 : unLoc $1) }
 
 gdrhs :: { Located [LGRHS RdrName] }
        : gdrhs gdrh            { LL ($2 : unLoc $1) }
@@ -951,7 +969,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)) }
                                { 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 '#-}'
                                { LL $ toOL [ LL $ SigD (SpecSig $2 t)
                                            | t <- $4] }
        | '{-# SPECIALISE' 'instance' inst_type '#-}'
@@ -962,10 +980,10 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
 
 exp   :: { LHsExpr RdrName }
        : infixexp '::' sigtype         { LL $ ExprWithTySig $1 $3 }
 
 exp   :: { LHsExpr RdrName }
        : infixexp '::' sigtype         { LL $ ExprWithTySig $1 $3 }
-       | fexp '-<' exp         { LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True }
-       | fexp '>-' exp         { LL $ HsArrApp $3 $1 placeHolderType HsFirstOrderApp False }
-       | fexp '-<<' exp        { LL $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True }
-       | fexp '>>-' exp        { LL $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False}
+       | infixexp '-<' exp             { LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True }
+       | infixexp '>-' exp             { LL $ HsArrApp $3 $1 placeHolderType HsFirstOrderApp False }
+       | infixexp '-<<' exp            { LL $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True }
+       | infixexp '>>-' exp            { LL $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False}
        | infixexp                      { $1 }
 
 infixexp :: { LHsExpr RdrName }
        | infixexp                      { $1 }
 
 infixexp :: { LHsExpr RdrName }
@@ -975,12 +993,12 @@ infixexp :: { LHsExpr RdrName }
 exp10 :: { LHsExpr RdrName }
        : '\\' aexp aexps opt_asig '->' exp     
                        {% checkPatterns ($2 : reverse $3) >>= \ ps -> 
 exp10 :: { LHsExpr RdrName }
        : '\\' aexp aexps opt_asig '->' exp     
                        {% checkPatterns ($2 : reverse $3) >>= \ ps -> 
-                          return (LL $ HsLam (LL $ Match ps $4
+                          return (LL $ HsLam (mkMatchGroup [LL $ Match ps $4
                                            (GRHSs (unguardedRHS $6) []
                                            (GRHSs (unguardedRHS $6) []
-                                                       placeHolderType))) }
+                                                       )])) }
        | 'let' binds 'in' exp                  { LL $ HsLet (unLoc $2) $4 }
        | 'if' exp 'then' exp 'else' exp        { LL $ HsIf $2 $4 $6 }
        | 'let' binds 'in' exp                  { LL $ HsLet (unLoc $2) $4 }
        | 'if' exp 'then' exp 'else' exp        { LL $ HsIf $2 $4 $6 }
-       | 'case' exp 'of' altslist              { LL $ HsCase $2 (unLoc $4) }
+       | 'case' exp 'of' altslist              { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
        | '-' fexp                              { LL $ mkHsNegApp $2 }
 
        | 'do' stmtlist                 {% let loc = comb2 $1 $2 in
        | '-' fexp                              { LL $ mkHsNegApp $2 }
 
        | 'do' stmtlist                 {% let loc = comb2 $1 $2 in
@@ -1057,7 +1075,7 @@ aexp2     :: { LHsExpr RdrName }
        | '$(' exp ')'          { LL $ HsSpliceE (mkHsSplice $2) }               -- $( exp )
 
        | TH_VAR_QUOTE qvar     { LL $ HsBracket (VarBr (unLoc $2)) }
        | '$(' 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_VAR_QUOTE gcon     { LL $ HsBracket (VarBr (unLoc $2)) }
        | TH_TY_QUOTE tyvar     { LL $ HsBracket (VarBr (unLoc $2)) }
        | TH_TY_QUOTE gtycon    { LL $ HsBracket (VarBr (unLoc $2)) }
        | '[|' exp '|]'         { LL $ HsBracket (ExpBr $2) }                       
        | TH_TY_QUOTE tyvar     { LL $ HsBracket (VarBr (unLoc $2)) }
        | TH_TY_QUOTE gtycon    { LL $ HsBracket (VarBr (unLoc $2)) }
        | '[|' exp '|]'         { LL $ HsBracket (ExpBr $2) }                       
@@ -1174,8 +1192,7 @@ alt       :: { LMatch RdrName }
                                            return (LL (Match [p] $2 (unLoc $3))) }
 
 alt_rhs :: { Located (GRHSs RdrName) }
                                            return (LL (Match [p] $2 (unLoc $3))) }
 
 alt_rhs :: { Located (GRHSs RdrName) }
-       : ralt wherebinds               { LL (GRHSs (unLoc $1) (unLoc $2)
-                                                placeHolderType) }
+       : ralt wherebinds               { LL (GRHSs (unLoc $1) (unLoc $2)) }
 
 ralt :: { Located [LGRHS RdrName] }
        : '->' exp                      { LL (unguardedRHS $2) }
 
 ralt :: { Located [LGRHS RdrName] }
        : '->' exp                      { LL (unguardedRHS $2) }
@@ -1340,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 }
@@ -1391,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
@@ -1444,7 +1471,7 @@ special_sym : '!' { L1 FSLIT("!") }
 -----------------------------------------------------------------------------
 -- Data constructors
 
 -----------------------------------------------------------------------------
 -- Data constructors
 
-qconid :: { Located RdrName }  -- Qualified or unqualifiedb
+qconid :: { Located RdrName }  -- Qualified or unqualified
        : conid                 { $1 }
        | QCONID                { L1 $ mkQual dataName (getQCONID $1) }
 
        : conid                 { $1 }
        | QCONID                { L1 $ mkQual dataName (getQCONID $1) }
 
@@ -1484,10 +1511,10 @@ close :: { () }
 -----------------------------------------------------------------------------
 -- Miscellaneous (mostly renamings)
 
 -----------------------------------------------------------------------------
 -- Miscellaneous (mostly renamings)
 
-modid  :: { Located ModuleName }
-       : CONID                 { L1 $ mkModuleNameFS (getCONID $1) }
+modid  :: { Located Module }
+       : CONID                 { L1 $ mkModuleFS (getCONID $1) }
         | QCONID               { L1 $ let (mod,c) = getQCONID $1 in
         | QCONID               { L1 $ let (mod,c) = getQCONID $1 in
-                                 mkModuleNameFS
+                                 mkModuleFS
                                   (mkFastString
                                     (unpackFS mod ++ '.':unpackFS c))
                                }
                                   (mkFastString
                                     (unpackFS mod ++ '.':unpackFS c))
                                }
@@ -1539,8 +1566,12 @@ comb4 a b c d = combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $
 sL :: SrcSpan -> a -> Located a
 sL span a = span `seq` L span a
 
 sL :: SrcSpan -> a -> Located a
 sL span a = span `seq` L span a
 
--- Make a source location that is just the filename.  This seems slightly
--- neater than trying to construct the span of the text within the file.
+-- Make a source location for the file.  We're a bit lazy here and just
+-- make a point SrcSpan at line 1, column 0.  Strictly speaking we should
+-- try to find the span of the whole file (ToDo).
 fileSrcSpan :: P SrcSpan
 fileSrcSpan :: P SrcSpan
-fileSrcSpan = do l <- getSrcLoc; return (mkGeneralSrcSpan (srcLocFile l))
+fileSrcSpan = do 
+  l <- getSrcLoc; 
+  let loc = mkSrcLoc (srcLocFile l) 1 0;
+  return (mkSrcSpan loc loc)
 }
 }
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)