projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2005-04-04 11:55:11 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 5cd9be4..c909f5d 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, 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,
                          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 Module
-import CmdLineOpts     ( opt_SccProfilingOn )
+import StaticFlags     ( opt_SccProfilingOn )
 import Type            ( Kind, mkArrowKind, liftedTypeKind )
 import BasicTypes      ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
                          Activation(..) )
 import OrdList
 import Type            ( Kind, mkArrowKind, liftedTypeKind )
 import BasicTypes      ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
                          Activation(..) )
 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: 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)
 
-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,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 }
 %%
 
@@ -280,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 
@@ -308,34 +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 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) }
+header_body :: { [LImportDecl RdrName] }
+       :  '{'            importdecls           { $2 }
+       |      vocurly    importdecls           { $2 }
 
 -----------------------------------------------------------------------------
 -- The Export List
 
 -----------------------------------------------------------------------------
 -- The Export List
@@ -392,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 }
 
@@ -441,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 
@@ -463,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
@@ -476,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 }
 
 -----------------------------------------------------------------------------
@@ -739,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 }
@@ -760,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 }
@@ -770,6 +776,7 @@ btype :: { LHsType RdrName }
 atype :: { LHsType RdrName }
        : gtycon                        { L1 (HsTyVar (unLoc $1)) }
        | tyvar                         { L1 (HsTyVar (unLoc $1)) }
 atype :: { LHsType RdrName }
        : gtycon                        { L1 (HsTyVar (unLoc $1)) }
        | tyvar                         { 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 }
@@ -784,7 +791,7 @@ 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_types1 :: { [LHsType RdrName] }
        : inst_type                     { [$1] }
@@ -838,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 [] }
@@ -865,39 +883,24 @@ 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 }
+       : 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).
 
 -- 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).
@@ -938,20 +941,19 @@ deriving :: { Located (Maybe [LHsType 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) }
        | gdrh                  { L1 [$1] }
 
 gdrh :: { LGRHS RdrName }
 
 gdrhs :: { Located [LGRHS RdrName] }
        : gdrhs gdrh            { LL ($2 : unLoc $1) }
        | gdrh                  { L1 [$1] }
 
 gdrh :: { LGRHS RdrName }
-       : '|' quals '=' exp     { LL $ GRHS (reverse (L (getLoc $4) (ResultStmt $4) : 
-                                                       unLoc $2)) }
+       : '|' quals '=' exp     { sL (comb2 $1 $>) $ GRHS (reverse (unLoc $2)) $4 }
 
 sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
        : infixexp '::' sigtype
 
 sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
        : infixexp '::' sigtype
@@ -977,10 +979,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 }
@@ -990,21 +992,20 @@ 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
-                                          checkDo loc (unLoc $2)  >>= \ stmts ->
-                                          return (L loc (mkHsDo DoExpr stmts)) }
+                                          checkDo loc (unLoc $2)  >>= \ (stmts,body) ->
+                                          return (L loc (mkHsDo DoExpr stmts body)) }
        | 'mdo' stmtlist                {% let loc = comb2 $1 $2 in
        | 'mdo' stmtlist                {% let loc = comb2 $1 $2 in
-                                          checkMDo loc (unLoc $2)  >>= \ stmts ->
-                                          return (L loc (mkHsDo MDoExpr stmts)) }
-
+                                          checkDo loc (unLoc $2)  >>= \ (stmts,body) ->
+                                          return (L loc (mkHsDo (MDoExpr noPostTcTable) stmts body)) }
         | scc_annot exp                                { LL $ if opt_SccProfilingOn
                                                        then HsSCC (unLoc $1) $2
                                                        else HsPar $2 }
         | scc_annot exp                                { LL $ if opt_SccProfilingOn
                                                        then HsSCC (unLoc $1) $2
                                                        else HsPar $2 }
@@ -1072,7 +1073,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) }                       
@@ -1113,13 +1114,11 @@ texps :: { [LHsExpr RdrName] }
 list :: { LHsExpr RdrName }
        : exp                   { L1 $ ExplicitList placeHolderType [$1] }
        | lexps                 { L1 $ ExplicitList placeHolderType (reverse (unLoc $1)) }
 list :: { LHsExpr RdrName }
        : exp                   { L1 $ ExplicitList placeHolderType [$1] }
        | lexps                 { L1 $ ExplicitList placeHolderType (reverse (unLoc $1)) }
-       | exp '..'              { LL $ ArithSeqIn (From $1) }
-       | exp ',' exp '..'      { LL $ ArithSeqIn (FromThen $1 $3) }
-       | exp '..' exp          { LL $ ArithSeqIn (FromTo $1 $3) }
-       | exp ',' exp '..' exp  { LL $ ArithSeqIn (FromThenTo $1 $3 $5) }
-       | exp pquals            { LL $ mkHsDo ListComp 
-                                       (reverse (L (getLoc $1) (ResultStmt $1) : 
-                                          unLoc $2)) }
+       | exp '..'              { LL $ ArithSeq noPostTcExpr (From $1) }
+       | exp ',' exp '..'      { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) }
+       | exp '..' exp          { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) }
+       | exp ',' exp '..' exp  { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) }
+       | exp pquals            { sL (comb2 $1 $>) $ mkHsDo ListComp (reverse (unLoc $2)) $1 }
 
 lexps :: { Located [LHsExpr RdrName] }
        : lexps ',' exp                 { LL ($3 : unLoc $1) }
 
 lexps :: { Located [LHsExpr RdrName] }
        : lexps ',' exp                 { LL ($3 : unLoc $1) }
@@ -1159,12 +1158,9 @@ parr :: { LHsExpr RdrName }
        | exp                           { L1 $ ExplicitPArr placeHolderType [$1] }
        | lexps                         { L1 $ ExplicitPArr placeHolderType 
                                                       (reverse (unLoc $1)) }
        | exp                           { L1 $ ExplicitPArr placeHolderType [$1] }
        | lexps                         { L1 $ ExplicitPArr placeHolderType 
                                                       (reverse (unLoc $1)) }
-       | exp '..' exp                  { LL $ PArrSeqIn (FromTo $1 $3) }
-       | exp ',' exp '..' exp          { LL $ PArrSeqIn (FromThenTo $1 $3 $5) }
-       | exp pquals                    { LL $ mkHsDo PArrComp 
-                                           (reverse (L (getLoc $1) (ResultStmt $1) :
-                                                unLoc $2))
-                                       }
+       | exp '..' exp                  { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) }
+       | exp ',' exp '..' exp          { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) }
+       | exp pquals                    { sL (comb2 $1 $>) $ mkHsDo PArrComp (reverse (unLoc $2)) $1 }
 
 -- We are reusing `lexps' and `pquals' from the list case.
 
 
 -- We are reusing `lexps' and `pquals' from the list case.
 
@@ -1189,8 +1185,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) }
@@ -1201,8 +1196,7 @@ gdpats :: { Located [LGRHS RdrName] }
        | gdpat                         { L1 [$1] }
 
 gdpat  :: { LGRHS RdrName }
        | gdpat                         { L1 [$1] }
 
 gdpat  :: { LGRHS RdrName }
-       : '|' quals '->' exp            { let r = L (getLoc $4) (ResultStmt $4)
-                                         in LL $ GRHS (reverse (r : unLoc $2)) }
+       : '|' quals '->' exp            { sL (comb2 $1 $>) $ GRHS (reverse (unLoc $2)) $4 }
 
 -----------------------------------------------------------------------------
 -- Statement sequences
 
 -----------------------------------------------------------------------------
 -- Statement sequences
@@ -1212,7 +1206,7 @@ stmtlist :: { Located [LStmt RdrName] }
        |     vocurly   stmts close     { $2 }
 
 --     do { ;; s ; s ; ; s ;; }
        |     vocurly   stmts close     { $2 }
 
 --     do { ;; s ; s ; ; s ;; }
--- The last Stmt should be a ResultStmt, but that's hard to enforce
+-- The last Stmt should be an expression, but that's hard to enforce
 -- here, because we need too much lookahead if we see do { e ; }
 -- So we use ExprStmts throughout, and switch the last one over
 -- in ParseUtils.checkDo instead
 -- here, because we need too much lookahead if we see do { e ; }
 -- So we use ExprStmts throughout, and switch the last one over
 -- in ParseUtils.checkDo instead
@@ -1234,13 +1228,13 @@ maybe_stmt :: { Maybe (LStmt RdrName) }
 stmt  :: { LStmt RdrName }
        : qual                          { $1 }
        | infixexp '->' exp             {% checkPattern $3 >>= \p ->
 stmt  :: { LStmt RdrName }
        : qual                          { $1 }
        | infixexp '->' exp             {% checkPattern $3 >>= \p ->
-                                          return (LL $ BindStmt p $1) }
-       | 'rec' stmtlist                { LL $ RecStmt (unLoc $2) undefined undefined undefined }
+                                          return (LL $ mkBindStmt p $1) }
+       | 'rec' stmtlist                { LL $ mkRecStmt (unLoc $2) }
 
 qual  :: { LStmt RdrName }
        : infixexp '<-' exp             {% checkPattern $1 >>= \p ->
 
 qual  :: { LStmt RdrName }
        : infixexp '<-' exp             {% checkPattern $1 >>= \p ->
-                                          return (LL $ BindStmt p $3) }
-       | exp                           { L1 $ ExprStmt $1 placeHolderType }
+                                          return (LL $ mkBindStmt p $3) }
+       | exp                           { L1 $ mkExprStmt $1 }
        | 'let' binds                   { LL $ LetStmt (unLoc $2) }
 
 -----------------------------------------------------------------------------
        | 'let' binds                   { LL $ LetStmt (unLoc $2) }
 
 -----------------------------------------------------------------------------
@@ -1355,10 +1349,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 }
@@ -1406,13 +1396,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
@@ -1459,7 +1463,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) }
 
@@ -1499,10 +1503,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))
                                }
@@ -1554,8 +1558,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)