[project @ 1997-06-13 04:11:47 by sof]

[ghc-hetmet.git] / ghc / compiler / rename / ParseUnfolding.y

diff --git a/ghc/compiler/rename/ParseUnfolding.y b/ghc/compiler/rename/ParseUnfolding.y
index 72a7c30..56330d9 100644 (file)
--- a/ghc/compiler/rename/ParseUnfolding.y
+++ b/ghc/compiler/rename/ParseUnfolding.y
@@ -15,7 +15,7 @@ import HsPragmas      ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas
 import IdInfo          ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo,
                          ArgUsageInfo, FBTypeInfo, ArityInfo, StrictnessInfo
                        )
-import Kind            ( Kind, mkArrowKind, mkTypeKind )
+import Kind            ( Kind, mkArrowKind, mkBoxedTypeKind )
 import Lex             
 
 import RnMonad         ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..),
@@ -27,7 +27,7 @@ import Name           ( OccName(..), isTCOcc, Provenance, SYN_IE(Module) )
 import SrcLoc          ( mkIfaceSrcLoc )
 import Util            ( panic{-, pprPanic ToDo:rm-} )
 import Pretty           ( Doc )
-import PprStyle         -- PprDebug for panic
+import Outputable      ( PprStyle(..) )
 import Maybes           ( MaybeErr(..) )
 
 ------------------------------------------------------------------
@@ -84,7 +84,7 @@ parseUnfolding ls =
 
        ARITY_PART      { ITarity }
        STRICT_PART     { ITstrict }
-       UNFOLD_PART     { ITunfold }
+       UNFOLD_PART     { ITunfold $$ }
        DEMAND          { ITdemand $$ }
        BOTTOM          { ITbottom }
        LAM             { ITlam }
@@ -124,13 +124,14 @@ id_info_item      :: { HsIdInfo RdrName }
 id_info_item   : ARITY_PART arity_info                 { HsArity $2 }
                | STRICT_PART strict_info               { HsStrictness $2 }
                | BOTTOM                                { HsStrictness mkBottomStrictnessInfo }
-               | UNFOLD_PART core_expr                 { HsUnfold $2 }
+               | UNFOLD_PART core_expr                 { HsUnfold $1 $2 }
 
 arity_info     :: { ArityInfo }
 arity_info     : INTEGER                                       { exactArity (fromInteger $1) }
 
 strict_info    :: { StrictnessInfo RdrName }
-strict_info    : DEMAND any_var_name                           { mkStrictnessInfo $1 (Just $2) }
+strict_info    : DEMAND any_var_name OCURLY data_names CCURLY  { mkStrictnessInfo $1 (Just ($2,$4)) }
+               | DEMAND any_var_name                           { mkStrictnessInfo $1 (Just ($2,[])) }
                | DEMAND                                        { mkStrictnessInfo $1 Nothing }
 
 core_expr      :: { UfExpr RdrName }
@@ -231,7 +232,7 @@ core_val_bndrs      :                                               { [] }
 
 core_tv_bndr   :: { UfBinder RdrName }
 core_tv_bndr   :  tv_name DCOLON akind                         { UfTyBinder $1 $3 }
-               |  tv_name                                      { UfTyBinder $1 mkTypeKind }
+               |  tv_name                                      { UfTyBinder $1 mkBoxedTypeKind }
 
 core_tv_bndrs  :: { [UfBinder RdrName] }
 core_tv_bndrs  :                                               { [] }
@@ -272,7 +273,11 @@ any_var_name       :  var_name             { $1 }
 
 var_names      :: { [RdrName] }
 var_names      :                       { [] }
-               | var_name var_names    { $1 : $2
+               | var_name var_names    { $1 : $2 }
+
+data_names     :: { [RdrName] }
+data_names     :                       { [] }
+               | data_name data_names  { $1 : $2
 
 --productions-for-types--------------------------------
                                             }
@@ -329,7 +334,7 @@ kind                :: { Kind }
                | akind RARROW kind     { mkArrowKind $1 $3 }
 
 akind          :: { Kind }
-               : VARSYM                { mkTypeKind {- ToDo: check that it's "*" -} }
+               : VARSYM                { mkBoxedTypeKind {- ToDo: check that it's "*" -} }
                | OPAREN kind CPAREN    { $2 }
 
 tv_name                :: { RdrName }