import PrimRep ( decodePrimRep )
import HsPragmas ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas )
import IdInfo ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo,
- ArgUsageInfo, FBTypeInfo
+ 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(..),
)
import Bag ( emptyBag, unitBag, snocBag )
import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
-import Name ( OccName(..), isTCOcc, Provenance )
+import Name ( OccName(..), isTCOcc, Provenance, SYN_IE(Module) )
import SrcLoc ( mkIfaceSrcLoc )
import Util ( panic{-, pprPanic ToDo:rm-} )
-import Pretty ( ppShow )
-import PprStyle -- PprDebug for panic
+import Pretty ( Doc )
+import Outputable ( PprStyle(..) )
import Maybes ( MaybeErr(..) )
------------------------------------------------------------------
case parseUnfold ls of
v@(Succeeded _) -> v
-- ill-formed unfolding, crash and burn.
- Failed err -> panic (ppShow 80 (err PprDebug))
+ Failed err -> panic (show (err PprDebug))
in
res
}
ARITY_PART { ITarity }
STRICT_PART { ITstrict }
- UNFOLD_PART { ITunfold }
+ UNFOLD_PART { ITunfold $$ }
DEMAND { ITdemand $$ }
BOTTOM { ITbottom }
LAM { ITlam }
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 }
core_expr : any_var_name { UfVar $1 }
- | qdata_name { UfVar $1 }
+ | data_name { UfVar $1 }
| core_lit { UfLit $1 }
| OPAREN core_expr CPAREN { $2 }
- | qdata_name OCURLY data_args CCURLY { UfCon $1 $3 }
+ | data_name OCURLY data_args CCURLY { UfCon $1 $3 }
| core_expr ATSIGN atype { UfApp $1 (UfTyArg $3) }
| core_expr core_arg { UfApp $1 $2 }
UfPrim (UfCCallOp $2 is_casm may_gc $5 $4)
$7
}
- | SCC OPAREN core_expr CPAREN { UfSCC $1 $3 }
+ | SCC core_expr { UfSCC $1 $2 }
rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] }
: { [] }
| core_val_bndr EQUAL core_expr SEMI rec_binds { ($1,$3) : $5 }
coerce :: { UfCoercion RdrName }
-coerce : COERCE_IN qdata_name { UfIn $2 }
- | COERCE_OUT qdata_name { UfOut $2 }
+coerce : COERCE_IN data_name { UfIn $2 }
+ | COERCE_OUT data_name { UfOut $2 }
prim_alts :: { [(Literal,UfExpr RdrName)] }
: { [] }
alg_alts :: { [(RdrName, [RdrName], UfExpr RdrName)] }
: { [] }
- | qdata_name var_names RARROW
+ | data_name var_names RARROW
core_expr SEMI alg_alts { ($1,$2,$4) : $6 }
core_default :: { UfDefault RdrName }
| var_name RARROW core_expr SEMI { UfBindDefault $1 $3 }
core_arg :: { UfArg RdrName }
- : var_name { UfVarArg $1 }
- | qvar_name { UfVarArg $1 }
- | qdata_name { UfVarArg $1 }
+ : any_var_name { UfVarArg $1 }
+ | data_name { UfVarArg $1 }
| core_lit { UfLitArg $1 }
core_args :: { [UfArg RdrName] }
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 : { [] }
| VARSYM { VarOcc $1 }
| BANG { VarOcc SLIT("!") {-sigh, double-sigh-} }
-qdata_name :: { RdrName }
-qdata_name : QCONID { varQual $1 }
+data_name :: { RdrName }
+data_name : QCONID { varQual $1 }
| QCONSYM { varQual $1 }
+ | CONID { Unqual (VarOcc $1) }
+ | CONSYM { Unqual (VarOcc $1) }
qvar_name :: { RdrName }
: QVARID { varQual $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--------------------------------
}
| class COMMA context_list1 { $1 : $3 }
class :: { (RdrName, RdrNameHsType) }
-class : qtc_name atype { ($1, $2) }
+class : tc_name atype { ($1, $2) }
type :: { RdrNameHsType }
type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 }
- | tautype { $1 }
-
-tautype :: { RdrNameHsType }
-tautype : btype { $1 }
- | btype RARROW tautype { MonoFunTy $1 $3 }
+ | btype RARROW type { MonoFunTy $1 $3 }
+ | btype { $1 }
types2 :: { [RdrNameHsType] {- Two or more -} }
types2 : type COMMA type { [$1,$3] }
| btype atype { MonoTyApp $1 $2 }
atype :: { RdrNameHsType }
-atype : qtc_name { MonoTyVar $1 }
+atype : tc_name { MonoTyVar $1 }
| tv_name { MonoTyVar $1 }
| OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 }
| OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 }
- | OCURLY qtc_name atype CCURLY { MonoDictTy $2 $3 }
+ | OCURLY tc_name atype CCURLY { MonoDictTy $2 $3 }
| OPAREN type CPAREN { $2 }
atypes :: { [RdrNameHsType] {- Zero or more -} }
| 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 }
tv_names :: { [RdrName] }
: { [] }
| tv_name tv_names { $1 : $2 }
-qtc_name :: { RdrName }
-qtc_name : QCONID { tcQual $1 }
+
+tc_name :: { RdrName }
+tc_name : QCONID { tcQual $1 }
+ | CONID { Unqual (TCOcc $1) }
+ | CONSYM { Unqual (TCOcc $1) }
+ | OPAREN RARROW CPAREN { Unqual (TCOcc SLIT("->")) }
projects / ghc-hetmet.git / blobdiff