projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Migrate cvs diff from fptools-assoc branch
[ghc-hetmet.git] / compiler / parser / Parser.y.pp
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index da16bff..da00825 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -45,6 +45,17 @@ import GLAEXTS
 
 {-
 -----------------------------------------------------------------------------
 
 {-
 -----------------------------------------------------------------------------
+26 July 2006
+
+Conflicts: 37 shift/reduce
+           1 reduce/reduce
+
+The reduce/reduce conflict is weird.  It's between tyconsym and consym, and I
+would think the two should never occur in the same context.
+
+  -=chak
+
+-----------------------------------------------------------------------------
 Conflicts: 36 shift/reduce (1.25)
 
 10 for abiguity in 'if x then y else z + 1'            [State 178]
 Conflicts: 36 shift/reduce (1.25)
 
 10 for abiguity in 'if x then y else z + 1'            [State 178]
@@ -83,10 +94,6 @@ Conflicts: 36 shift/reduce (1.25)
        might be the start of the declaration with the activation being
        empty.  --SDM 1/4/2002
 
        might be the start of the declaration with the activation being
        empty.  --SDM 1/4/2002
 
-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
 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
@@ -346,10 +353,13 @@ maybeexports :: { Maybe [LIE RdrName] }
        :  '(' exportlist ')'                   { Just $2 }
        |  {- empty -}                          { Nothing }
 
        :  '(' exportlist ')'                   { Just $2 }
        |  {- empty -}                          { Nothing }
 
-exportlist :: { [LIE RdrName] }
-       :  exportlist ',' export                { $3 : $1 }
-       |  exportlist ','                       { $1 }
-       |  export                               { [$1]  }
+exportlist  :: { [LIE RdrName] }
+       : ','                                   { [] }
+       | exportlist1                           { $1 }
+
+exportlist1 :: { [LIE RdrName] }
+       :  export                               { [$1] }
+       |  export ',' exportlist                { $1 : $3 }
        |  {- empty -}                          { [] }
 
    -- No longer allow things like [] and (,,,) to be exported
        |  {- empty -}                          { [] }
 
    -- No longer allow things like [] and (,,,) to be exported
@@ -403,8 +413,8 @@ maybeimpspec :: { Located (Maybe (Bool, [LIE RdrName])) }
        | {- empty -}                           { noLoc Nothing }
 
 impspec :: { Located (Bool, [LIE RdrName]) }
        | {- empty -}                           { noLoc Nothing }
 
 impspec :: { Located (Bool, [LIE RdrName]) }
-       :  '(' exportlist ')'                   { LL (False, reverse $2) }
-       |  'hiding' '(' exportlist ')'          { LL (True,  reverse $3) }
+       :  '(' exportlist ')'                   { LL (False, $2) }
+       |  'hiding' '(' exportlist ')'          { LL (True,  $3) }
 
 -----------------------------------------------------------------------------
 -- Fixity Declarations
 
 -----------------------------------------------------------------------------
 -- Fixity Declarations
@@ -431,10 +441,12 @@ topdecls :: { OrdList (LHsDecl RdrName) }
        | topdecl                       { $1 }
 
 topdecl :: { OrdList (LHsDecl RdrName) }
        | topdecl                       { $1 }
 
 topdecl :: { OrdList (LHsDecl RdrName) }
-       : tycl_decl                     { unitOL (L1 (TyClD (unLoc $1))) }
+       : cl_decl                       { unitOL (L1 (TyClD (unLoc $1))) }
+       | ty_decl                       {% checkTopTyClD $1 >>= return.unitOL.L1 }
        | 'instance' inst_type where
        | 'instance' inst_type where
-               { let (binds,sigs) = cvBindsAndSigs (unLoc $3)
-                 in unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs))) }
+               { let (binds, sigs, ats) = cvBindsAndSigs (unLoc $3)
+                 in unitOL (L (comb3 $1 $2 $3) 
+                           (InstD (InstDecl $2 binds sigs ats))) }
        | 'default' '(' comma_types0 ')'        { unitOL (LL $ DefD (DefaultDecl $3)) }
        | 'foreign' fdecl                       { unitOL (LL (unLoc $2)) }
        | '{-# DEPRECATED' deprecations '#-}'   { $2 }
        | 'default' '(' comma_types0 ')'        { unitOL (LL $ DefD (DefaultDecl $3)) }
        | 'foreign' fdecl                       { unitOL (LL (unLoc $2)) }
        | '{-# DEPRECATED' deprecations '#-}'   { $2 }
@@ -447,7 +459,21 @@ topdecl :: { OrdList (LHsDecl RdrName) }
                                                        L1 $ HsVar (mkUnqual varName (getTH_ID_SPLICE $1))
                                                  )) }
 
                                                        L1 $ HsVar (mkUnqual varName (getTH_ID_SPLICE $1))
                                                  )) }
 
-tycl_decl :: { LTyClDecl RdrName }
+-- Type classes
+--
+cl_decl :: { LTyClDecl RdrName }
+       : 'class' tycl_hdr fds where
+               {% do { let { (binds, sigs, ats)           = 
+                               cvBindsAndSigs (unLoc $4)
+                           ; (ctxt, tc, tvs, Just tparms) = unLoc $2}
+                      ; checkTyVars tparms
+                     ; return $ L (comb4 $1 $2 $3 $4) 
+                                  (mkClassDecl (ctxt, tc, tvs) 
+                                               (unLoc $3) sigs binds ats) } }
+
+-- Type declarations
+--
+ty_decl :: { LTyClDecl RdrName }
        : 'type' type '=' ctype 
                -- Note type on the left of the '='; this allows
                -- infix type constructors to be declared
        : 'type' type '=' ctype 
                -- Note type on the left of the '='; this allows
                -- infix type constructors to be declared
@@ -470,13 +496,6 @@ tycl_decl :: { LTyClDecl RdrName }
                { L (comb4 $1 $2 $4 $5)
                    (mkTyData (unLoc $1) (unLoc $2) $3 (reverse (unLoc $5)) (unLoc $6)) }
 
                { L (comb4 $1 $2 $4 $5)
                    (mkTyData (unLoc $1) (unLoc $2) $3 (reverse (unLoc $5)) (unLoc $6)) }
 
-       | 'class' tycl_hdr fds where
-               { let 
-                       (binds,sigs) = cvBindsAndSigs (unLoc $4)
-                 in
-                 L (comb4 $1 $2 $3 $4) (mkClassDecl (unLoc $2) (unLoc $3) sigs 
-                                         binds) }
-
 data_or_newtype :: { Located NewOrData }
        : 'data'        { L1 DataType }
        | 'newtype'     { L1 NewType }
 data_or_newtype :: { Located NewOrData }
        : 'data'        { L1 DataType }
        | 'newtype'     { L1 NewType }
@@ -485,19 +504,49 @@ opt_kind_sig :: { Maybe Kind }
        :                               { Nothing }
        | '::' kind                     { Just $2 }
 
        :                               { Nothing }
        | '::' kind                     { Just $2 }
 
--- tycl_hdr parses the header of a type or class decl,
+-- tycl_hdr parses the header of a type decl,
 -- which takes the form
 --     T a b
 --     Eq a => T a
 --     (Eq a, Ord b) => T a b
 -- which takes the form
 --     T a b
 --     Eq a => T a
 --     (Eq a, Ord b) => T a b
+--      T Int [a]                      -- for associated types
 -- Rather a lot of inlining here, else we get reduce/reduce errors
 -- Rather a lot of inlining here, else we get reduce/reduce errors
-tycl_hdr :: { Located (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName]) }
+tycl_hdr :: { Located (LHsContext RdrName, 
+                      Located RdrName, 
+                      [LHsTyVarBndr RdrName],
+                      Maybe [LHsType RdrName]) }
        : context '=>' type             {% checkTyClHdr $1         $3 >>= return.LL }
        | type                          {% checkTyClHdr (noLoc []) $1 >>= return.L1 }
 
 -----------------------------------------------------------------------------
 -- Nested declarations
 
        : context '=>' type             {% checkTyClHdr $1         $3 >>= return.LL }
        | type                          {% checkTyClHdr (noLoc []) $1 >>= return.L1 }
 
 -----------------------------------------------------------------------------
 -- Nested declarations
 
+-- Type declaration or value declaration
+--
+tydecl  :: { Located (OrdList (LHsDecl RdrName)) }
+tydecl  : ty_decl                      { LL (unitOL (L1 (TyClD (unLoc $1)))) }
+       | decl                          { $1 }
+
+tydecls        :: { Located (OrdList (LHsDecl RdrName)) }      -- Reversed
+       : tydecls ';' tydecl            { LL (unLoc $1 `appOL` unLoc $3) }
+       | tydecls ';'                   { LL (unLoc $1) }
+       | tydecl                        { $1 }
+       | {- empty -}                   { noLoc nilOL }
+
+
+tydecllist 
+        :: { Located (OrdList (LHsDecl RdrName)) }     -- Reversed
+       : '{'            tydecls '}'    { LL (unLoc $2) }
+       |     vocurly    tydecls close  { $2 }
+
+-- Form of the body of class and instance declarations
+--
+where  :: { Located (OrdList (LHsDecl RdrName)) }      -- Reversed
+                               -- No implicit parameters
+                               -- May have type declarations
+       : 'where' tydecllist            { LL (unLoc $2) }
+       | {- empty -}                   { noLoc nilOL }
+
 decls  :: { Located (OrdList (LHsDecl RdrName)) }      
        : decls ';' decl                { LL (unLoc $1 `appOL` unLoc $3) }
        | decls ';'                     { LL (unLoc $1) }
 decls  :: { Located (OrdList (LHsDecl RdrName)) }      
        : decls ';' decl                { LL (unLoc $1 `appOL` unLoc $3) }
        | decls ';'                     { LL (unLoc $1) }
@@ -509,17 +558,16 @@ decllist :: { Located (OrdList (LHsDecl RdrName)) }
        : '{'            decls '}'      { LL (unLoc $2) }
        |     vocurly    decls close    { $2 }
 
        : '{'            decls '}'      { LL (unLoc $2) }
        |     vocurly    decls close    { $2 }
 
-where  :: { Located (OrdList (LHsDecl RdrName)) }
-                               -- No implicit parameters
-       : 'where' decllist              { LL (unLoc $2) }
-       | {- empty -}                   { noLoc nilOL }
-
+-- Binding groups other than those of class and instance declarations
+--
 binds  ::  { Located (HsLocalBinds RdrName) }          -- May have implicit parameters
 binds  ::  { Located (HsLocalBinds RdrName) }          -- May have implicit parameters
+                                               -- No type declarations
        : decllist                      { L1 (HsValBinds (cvBindGroup (unLoc $1))) }
        | '{'            dbinds '}'     { LL (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
        |     vocurly    dbinds close   { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
 
 wherebinds :: { Located (HsLocalBinds RdrName) }       -- May have implicit parameters
        : decllist                      { L1 (HsValBinds (cvBindGroup (unLoc $1))) }
        | '{'            dbinds '}'     { LL (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
        |     vocurly    dbinds close   { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
 
 wherebinds :: { Located (HsLocalBinds RdrName) }       -- May have implicit parameters
+                                               -- No type declarations
        : 'where' binds                 { LL (unLoc $2) }
        | {- empty -}                   { noLoc emptyLocalBinds }
 
        : 'where' binds                 { LL (unLoc $2) }
        | {- empty -}                   { noLoc emptyLocalBinds }
 
@@ -578,123 +626,14 @@ deprecation :: { OrdList (LHsDecl RdrName) }
 -----------------------------------------------------------------------------
 -- Foreign import and export declarations
 
 -----------------------------------------------------------------------------
 -- Foreign import and export declarations
 
--- for the time being, the following accepts foreign declarations conforming
--- to the FFI Addendum, Version 1.0 as well as pre-standard declarations
---
--- * a flag indicates whether pre-standard declarations have been used and
---   triggers a deprecation warning further down the road
---
--- NB: The first two rules could be combined into one by replacing `safety1'
---     with `safety'.  However, the combined rule conflicts with the
---     DEPRECATED rules.
---
 fdecl :: { LHsDecl RdrName }
 fdecl :: { LHsDecl RdrName }
-fdecl : 'import' callconv safety1 fspec
+fdecl : 'import' callconv safety fspec
                {% mkImport $2 $3 (unLoc $4) >>= return.LL }
                {% mkImport $2 $3 (unLoc $4) >>= return.LL }
-      | 'import' callconv         fspec                
+      | 'import' callconv        fspec         
                {% do { d <- mkImport $2 (PlaySafe False) (unLoc $3);
                        return (LL d) } }
       | 'export' callconv fspec
                {% mkExport $2 (unLoc $3) >>= return.LL }
                {% do { d <- mkImport $2 (PlaySafe False) (unLoc $3);
                        return (LL d) } }
       | 'export' callconv fspec
                {% mkExport $2 (unLoc $3) >>= return.LL }
-        -- the following syntax is DEPRECATED
-      | fdecl1DEPRECATED                       { L1 (ForD (unLoc $1)) }
-      | fdecl2DEPRECATED                       { L1 (unLoc $1) }
-
-fdecl1DEPRECATED :: { LForeignDecl RdrName }
-fdecl1DEPRECATED 
-  ----------- DEPRECATED label decls ------------
-  : 'label' ext_name varid '::' sigtype
-    { LL $ ForeignImport $3 $5 (CImport defaultCCallConv (PlaySafe False) nilFS nilFS 
-                                  (CLabel ($2 `orElse` mkExtName (unLoc $3)))) True }
-
-  ----------- DEPRECATED ccall/stdcall decls ------------
-  --
-  -- NB: This business with the case expression below may seem overly
-  --    complicated, but it is necessary to avoid some conflicts.
-
-    -- DEPRECATED variant #1: lack of a calling convention specification
-    --                       (import) 
-  | 'import' {-no callconv-} ext_name safety varid_no_unsafe '::' sigtype
-    { let
-       target = StaticTarget ($2 `orElse` mkExtName (unLoc $4))
-      in
-      LL $ ForeignImport $4 $6 (CImport defaultCCallConv $3 nilFS nilFS 
-                                  (CFunction target)) True }
-
-    -- DEPRECATED variant #2: external name consists of two separate strings
-    --                       (module name and function name) (import)
-  | 'import' callconv STRING STRING safety varid_no_unsafe '::' sigtype
-    {% case $2 of
-         DNCall      -> parseError (comb2 $1 $>) "Illegal format of .NET foreign import"
-        CCall cconv -> return $
-           let
-            imp = CFunction (StaticTarget (getSTRING $4))
-          in
-          LL $ ForeignImport $6 $8 (CImport cconv $5 nilFS nilFS imp) True }
-
-    -- DEPRECATED variant #3: `unsafe' after entity
-  | 'import' callconv STRING 'unsafe' varid_no_unsafe '::' sigtype
-    {% case $2 of
-         DNCall      -> parseError (comb2 $1 $>) "Illegal format of .NET foreign import"
-        CCall cconv -> return $
-           let
-            imp = CFunction (StaticTarget (getSTRING $3))
-          in
-          LL $ ForeignImport $5 $7 (CImport cconv PlayRisky nilFS nilFS imp) True }
-
-    -- DEPRECATED variant #4: use of the special identifier `dynamic' without
-    --                       an explicit calling convention (import)
-  | 'import' {-no callconv-} 'dynamic' safety varid_no_unsafe '::' sigtype
-    { LL $ ForeignImport $4 $6 (CImport defaultCCallConv $3 nilFS nilFS 
-                                  (CFunction DynamicTarget)) True }
-
-    -- DEPRECATED variant #5: use of the special identifier `dynamic' (import)
-  | 'import' callconv 'dynamic' safety varid_no_unsafe '::' sigtype
-    {% case $2 of
-         DNCall      -> parseError (comb2 $1 $>) "Illegal format of .NET foreign import"
-        CCall cconv -> return $
-          LL $ ForeignImport $5 $7 (CImport cconv $4 nilFS nilFS 
-                                       (CFunction DynamicTarget)) True }
-
-    -- DEPRECATED variant #6: lack of a calling convention specification
-    --                       (export) 
-  | 'export' {-no callconv-} ext_name varid '::' sigtype
-    { LL $ ForeignExport $3 $5 (CExport (CExportStatic ($2 `orElse` mkExtName (unLoc $3))
-                                  defaultCCallConv)) True }
-
-    -- DEPRECATED variant #7: external name consists of two separate strings
-    --                       (module name and function name) (export)
-  | 'export' callconv STRING STRING varid '::' sigtype
-    {% case $2 of
-         DNCall      -> parseError (comb2 $1 $>) "Illegal format of .NET foreign import"
-        CCall cconv -> return $
-           LL $ ForeignExport $5 $7 
-                        (CExport (CExportStatic (getSTRING $4) cconv)) True }
-
-    -- DEPRECATED variant #8: use of the special identifier `dynamic' without
-    --                       an explicit calling convention (export)
-  | 'export' {-no callconv-} 'dynamic' varid '::' sigtype
-    { LL $ ForeignImport $3 $5 (CImport defaultCCallConv (PlaySafe False) nilFS nilFS 
-                                  CWrapper) True }
-
-    -- DEPRECATED variant #9: use of the special identifier `dynamic' (export)
-  | 'export' callconv 'dynamic' varid '::' sigtype
-    {% case $2 of
-         DNCall      -> parseError (comb2 $1 $>) "Illegal format of .NET foreign import"
-        CCall cconv -> return $
-          LL $ ForeignImport $4 $6 
-                (CImport cconv (PlaySafe False) nilFS nilFS CWrapper) True }
-
-  ----------- DEPRECATED .NET decls ------------
-  -- NB: removed the .NET call declaration, as it is entirely subsumed
-  --     by the new standard FFI declarations
-
-fdecl2DEPRECATED :: { LHsDecl RdrName }
-fdecl2DEPRECATED 
-  : 'import' 'dotnet' 'type' ext_name tycon { LL $ TyClD (ForeignType $5 $4 DNType) }
-    -- left this one unchanged for the moment as type imports are not
-    -- covered currently by the FFI standard -=chak
-
 
 callconv :: { CallConv }
          : 'stdcall'                   { CCall  StdCallConv }
 
 callconv :: { CallConv }
          : 'stdcall'                   { CCall  StdCallConv }
@@ -703,15 +642,8 @@ callconv :: { CallConv }
 
 safety :: { Safety }
        : 'unsafe'                      { PlayRisky }
 
 safety :: { Safety }
        : 'unsafe'                      { PlayRisky }
-       | 'safe'                        { PlaySafe False }
-       | 'threadsafe'                  { PlaySafe True  }
-       | {- empty -}                   { PlaySafe False }
-
-safety1 :: { Safety }
-       : 'unsafe'                      { PlayRisky }
        | 'safe'                        { PlaySafe  False }
        | 'threadsafe'                  { PlaySafe  True }
        | 'safe'                        { PlaySafe  False }
        | 'threadsafe'                  { PlaySafe  True }
-         -- only needed to avoid conflicts with the DEPRECATED rules
 
 fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }
        : STRING var '::' sigtype      { LL (L (getLoc $1) (getSTRING $1), $2, $4) }
 
 fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }
        : STRING var '::' sigtype      { LL (L (getLoc $1) (getSTRING $1), $2, $4) }
@@ -720,13 +652,6 @@ fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }
          -- the meaning of an empty entity string depends on the calling
          -- convention
 
          -- the meaning of an empty entity string depends on the calling
          -- convention
 
--- DEPRECATED syntax
-ext_name :: { Maybe CLabelString }
-       : STRING                { Just (getSTRING $1) }
-       | STRING STRING         { Just (getSTRING $2) } -- Ignore "module name" for now
-       | {- empty -}           { Nothing }
-
-
 -----------------------------------------------------------------------------
 -- Type signatures
 
 -----------------------------------------------------------------------------
 -- Type signatures
 
@@ -877,7 +802,7 @@ gadt_constr :: { LConDecl RdrName }
               { LL (mkGadtDecl $1 $3) } 
         -- Syntax: Maybe merge the record stuff with the single-case above?
         --         (to kill the mostly harmless reduce/reduce error)
               { LL (mkGadtDecl $1 $3) } 
         -- Syntax: Maybe merge the record stuff with the single-case above?
         --         (to kill the mostly harmless reduce/reduce error)
-        -- XXX revisit autrijus
+        -- XXX revisit audreyt
        | constr_stuff_record '::' sigtype
                { let (con,details) = unLoc $1 in 
                  LL (ConDecl con Implicit [] (noLoc []) details (ResTyGADT $3)) }
        | constr_stuff_record '::' sigtype
                { let (con,details) = unLoc $1 in 
                  LL (ConDecl con Implicit [] (noLoc []) details (ResTyGADT $3)) }
@@ -1228,6 +1153,8 @@ alts1     :: { Located [LMatch RdrName] }
 alt    :: { LMatch RdrName }
        : infixexp opt_sig alt_rhs      {%  checkPattern $1 >>= \p ->
                                            return (LL (Match [p] $2 (unLoc $3))) }
 alt    :: { LMatch RdrName }
        : infixexp opt_sig alt_rhs      {%  checkPattern $1 >>= \p ->
                                            return (LL (Match [p] $2 (unLoc $3))) }
+       | '!' infixexp opt_sig alt_rhs  {%  checkPattern $2 >>= \p ->
+                                           return (LL (Match [LL $ BangPat p] $3 (unLoc $4))) }
 
 alt_rhs :: { Located (GRHSs RdrName) }
        : ralt wherebinds               { LL (GRHSs (unLoc $1) (unLoc $2)) }
 
 alt_rhs :: { Located (GRHSs RdrName) }
        : ralt wherebinds               { LL (GRHSs (unLoc $1) (unLoc $2)) }
@@ -1496,6 +1423,7 @@ special_id
        | 'dynamic'             { L1 FSLIT("dynamic") }
        | 'stdcall'             { L1 FSLIT("stdcall") }
        | 'ccall'               { L1 FSLIT("ccall") }
        | 'dynamic'             { L1 FSLIT("dynamic") }
        | 'stdcall'             { L1 FSLIT("stdcall") }
        | 'ccall'               { L1 FSLIT("ccall") }
+       | 'iso'                 { L1 FSLIT("iso") }
 
 special_sym :: { Located FastString }
 special_sym : '!'      { L1 FSLIT("!") }
 
 special_sym :: { Located FastString }
 special_sym : '!'      { L1 FSLIT("!") }
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)