import HsSyn -- quite a bit of stuff
import RdrHsSyn -- oodles of synonyms
-import HsTypes ( mkHsForAllTy )
+import HsTypes ( mkHsForAllTy, mkHsUsForAllTy )
import HsCore
import Const ( Literal(..), mkMachInt_safe )
import BasicTypes ( Fixity(..), FixityDirection(..),
import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) )
import HsPragmas ( noDataPragmas, noClassPragmas )
import Type ( Kind, mkArrowKind, boxedTypeKind, openTypeKind, UsageAnn(..) )
-import IdInfo ( ArityInfo, exactArity, CprInfo(..) )
+import IdInfo ( ArityInfo, exactArity, CprInfo(..), InlinePragInfo(..) )
import Lex
import RnMonad ( ImportVersion, LocalVersion, ParsedIface(..), WhatsImported(..),
import RdrName ( RdrName, mkRdrUnqual, mkSysQual, mkSysUnqual )
import Name ( OccName, Provenance )
import OccName ( mkSysOccFS,
- tcName, varName, dataName, clsName, tvName,
+ tcName, varName, ipName, dataName, clsName, tvName, uvName,
EncodedFS
)
import Module ( ModuleName, mkSysModuleFS )
'label' { ITlabel }
'dynamic' { ITdynamic }
'unsafe' { ITunsafe }
+ 'with' { ITwith }
'__interface' { ITinterface } -- interface keywords
'__export' { IT__export }
'__scc' { ITscc }
'__sccC' { ITsccAllCafs }
- '__o' { ITonce }
- '__m' { ITmany }
+ '__u' { ITusage }
+ '__fuall' { ITfuall }
'__A' { ITarity }
'__P' { ITspecialise }
'__U' { ITunfold $$ }
'__S' { ITstrict $$ }
'__R' { ITrules }
+ '__D' { ITdeprecated }
'__M' { ITcprinfo $$ }
'..' { ITdotdot } -- reserved symbols
QVARSYM { ITqvarsym $$ }
QCONSYM { ITqconsym $$ }
+ IPVARID { ITipvarid $$ } -- GHC extension
+
PRAGMA { ITpragma $$ }
CHAR { ITchar $$ }
iface_stuff :: { IfaceStuff }
iface_stuff : iface { let (nm, iff) = $1 in PIface nm iff }
- | type { PType $1 }
- | id_info { PIdInfo $1 }
- | '__R' rules { PRules $2 }
+ | type { PType $1 }
+ | id_info { PIdInfo $1 }
+ | '__R' rules { PRules $2 }
+ | '__D' deprecs { PDeprecs $2 }
iface :: { (ModuleName, ParsedIface) }
import_part
instance_decl_part
decls_part
- rules_part
+ rules_and_deprecs
{ ( $2 -- Module name
, ParsedIface {
pi_mod = fromInteger $3, -- Module version
pi_usages = $8, -- Usages
pi_insts = $9, -- Local instances
pi_decls = $10, -- Decls
- pi_rules = $11 -- Rules
+ pi_rules = fst $11, -- Rules
+ pi_deprecs = snd $11 -- Deprecations
} ) }
--------------------------------------------------------------------------
{ TyClD (TyData DataType $3 $4 $5 $6 Nothing noDataPragmas $1) }
| src_loc 'newtype' decl_context tc_name tv_bndrs newtype_constr
{ TyClD (TyData NewType $3 $4 $5 $6 Nothing noDataPragmas $1) }
- | src_loc 'class' decl_context tc_name tv_bndrs csigs
- { TyClD (mkClassDecl $3 $4 $5 $6 EmptyMonoBinds
+ | src_loc 'class' decl_context tc_name tv_bndrs fds csigs
+ { TyClD (mkClassDecl $3 $4 $5 $6 $7 EmptyMonoBinds
noClassPragmas $1) }
| src_loc fixity mb_fix var_or_data_name
{ FixD (FixitySig $4 (Fixity $3 $2) $1) }
maybe_idinfo :: { RdrName -> [HsIdInfo RdrName] }
maybe_idinfo : {- empty -} { \_ -> [] }
- | src_loc PRAGMA { \x ->
- case parseIface $2
- PState{bol = 0#, atbol = 1#,
- context = [],
- glasgow_exts = 1#,
- loc = $1 } of
+ | pragma { \x -> case $1 of
POk _ (PIdInfo id_info) -> id_info
PFailed err ->
pprPanic "IdInfo parse failed"
(vcat [ppr x, err])
}
+pragma :: { ParseResult IfaceStuff }
+pragma : src_loc PRAGMA { parseIface $2 PState{ bol = 0#, atbol = 1#,
+ context = [],
+ glasgow_exts = 1#,
+ loc = $1 }
+ }
+
-----------------------------------------------------------------------------
-rules_part :: { [RdrNameRuleDecl] }
-rules_part : {- empty -} { [] }
- | src_loc PRAGMA { case parseIface $2
- PState{bol = 0#, atbol = 1#,
- context = [],
- glasgow_exts = 1#,
- loc = $1 } of
- POk _ (PRules rules) -> rules
- PFailed err ->
- pprPanic "Rules parse failed" err
+rules_and_deprecs :: { ([RdrNameRuleDecl], [RdrNameDeprecation]) }
+rules_and_deprecs : {- empty -} { ([], []) }
+ | rules_and_deprecs rule_or_deprec
+ { let
+ append2 (xs1,ys1) (xs2,ys2) =
+ (xs1 `app` xs2, ys1 `app` ys2)
+ xs `app` [] = xs -- performance paranoia
+ xs `app` ys = xs ++ ys
+ in append2 $1 $2
}
+rule_or_deprec :: { ([RdrNameRuleDecl], [RdrNameDeprecation]) }
+rule_or_deprec : pragma { case $1 of
+ POk _ (PRules rules) -> (rules,[])
+ POk _ (PDeprecs deprecs) -> ([],deprecs)
+ PFailed err -> pprPanic "Rules/Deprecations parse failed" err
+ }
+
+-----------------------------------------------------------------------------
+
rules :: { [RdrNameRuleDecl] }
: {- empty -} { [] }
| rule ';' rules { $1:$3 }
-----------------------------------------------------------------------------
+deprecs :: { [RdrNameDeprecation] }
+deprecs : {- empty -} { [] }
+ | deprecs deprec ';' { $2 : $1 }
+
+deprec :: { RdrNameDeprecation }
+deprec : STRING { Deprecation (IEModuleContents undefined) $1 }
+ | deprec_name STRING { Deprecation $1 $2 }
+
+-- SUP: TEMPORARY HACK
+deprec_name :: { RdrNameIE }
+ : var_name { IEVar $1 }
+
+-----------------------------------------------------------------------------
+
version :: { Version }
version : INTEGER { fromInteger $1 }
--------------------------------------------------------------------------
type :: { RdrNameHsType }
-type : '__forall' forall context '=>' type
- { mkHsForAllTy $2 $3 $5 }
+type : '__fuall' fuall '=>' type { mkHsUsForAllTy $2 $4 }
+ | '__forall' forall context '=>' type
+ { mkHsForAllTy (Just $2) $3 $5 }
| btype '->' type { MonoFunTy $1 $3 }
| btype { $1 }
+fuall :: { [RdrName] }
+fuall : '[' uv_bndrs ']' { $2 }
+
forall :: { [HsTyVar RdrName] }
forall : '[' tv_bndrs ']' { $2 }
context_list1 : class { [$1] }
| class ',' context_list1 { $1 : $3 }
-class :: { (RdrName, [RdrNameHsType]) }
-class : qcls_name atypes { ($1, $2) }
+class :: { HsPred RdrName }
+class : qcls_name atypes { (HsPClass $1 $2) }
+ | IPVARID '::' type { (HsPIParam (mkSysUnqual ipName $1) $3) }
+
+types0 :: { [RdrNameHsType] {- Zero or more -} }
+types0 : {- empty -} { [ ] }
+ | type { [ $1 ] }
+ | types2 { $1 }
types2 :: { [RdrNameHsType] {- Two or more -} }
types2 : type ',' type { [$1,$3] }
btype :: { RdrNameHsType }
btype : atype { $1 }
| btype atype { MonoTyApp $1 $2 }
- | '__o' atype { MonoUsgTy UsOnce $2 }
- | '__m' atype { MonoUsgTy UsMany $2 }
+ | '__u' usage atype { MonoUsgTy $2 $3 }
+
+usage :: { MonoUsageAnn RdrName }
+usage : '-' { MonoUsOnce }
+ | '!' { MonoUsMany }
+ | uv_name { MonoUsVar $1 }
atype :: { RdrNameHsType }
atype : qtc_name { MonoTyVar $1 }
| tv_name { MonoTyVar $1 }
| '(' types2 ')' { MonoTupleTy $2 True{-boxed-} }
- | '(#' type '#)' { MonoTupleTy [$2] False{-unboxed-} }
- | '(#' types2 '#)' { MonoTupleTy $2 False{-unboxed-} }
+ | '(#' types0 '#)' { MonoTupleTy $2 False{-unboxed-} }
| '[' type ']' { MonoListTy $2 }
| '{' qcls_name atypes '}' { MonoDictTy $2 $3 }
+ | '{' IPVARID '::' type '}' { MonoIParamTy (mkSysUnqual ipName $2) $4 }
| '(' type ')' { $2 }
-- This one is dealt with via qtc_name
---------------------------------------------------
var_fs :: { EncodedFS }
: VARID { $1 }
- | VARSYM { $1 }
| '!' { SLIT("!") }
| 'as' { SLIT("as") }
| 'qualified' { SLIT("qualified") }
| 'label' { SLIT("label") }
| 'dynamic' { SLIT("dynamic") }
| 'unsafe' { SLIT("unsafe") }
+ | 'with' { SLIT("with") }
qvar_fs :: { (EncodedFS, EncodedFS) }
: QVARID { $1 }
| qdata_fs { mkSysQual clsName $1 }
---------------------------------------------------
+uv_name :: { RdrName }
+ : VARID { mkSysUnqual uvName $1 }
+
+uv_bndr :: { RdrName }
+ : uv_name { $1 }
+
+uv_bndrs :: { [RdrName] }
+ : { [] }
+ | uv_bndr uv_bndrs { $1 : $2 }
+
+---------------------------------------------------
tv_name :: { RdrName }
: VARID { mkSysUnqual tvName $1 }
| VARSYM { mkSysUnqual tvName $1 {- Allow t2 as a tyvar -} }
| tv_bndr tv_bndrs { $1 : $2 }
---------------------------------------------------
+fds :: { [([RdrName], [RdrName])] }
+ : {- empty -} { [] }
+ | '|' fds1 { reverse $2 }
+
+fds1 :: { [([RdrName], [RdrName])] }
+ : fds1 ',' fd { $3 : $1 }
+ | fd { [$1] }
+
+fd :: { ([RdrName], [RdrName]) }
+ : varids0 '->' varids0 { (reverse $1, reverse $3) }
+
+varids0 :: { [RdrName] }
+ : {- empty -} { [] }
+ | varids0 tv_name { $2 : $1 }
+
+---------------------------------------------------
kind :: { Kind }
: akind { $1 }
| akind '->' kind { mkArrowKind $1 $3 }
id_info :: { [HsIdInfo RdrName] }
: { [] }
| id_info_item id_info { $1 : $2 }
- | strict_info id_info { $1 ++ $2 }
id_info_item :: { HsIdInfo RdrName }
- : '__A' arity_info { HsArity $2 }
- | '__U' core_expr { HsUnfold $1 (Just $2) }
- | '__U' { HsUnfold $1 Nothing }
+ : '__A' INTEGER { HsArity (exactArity (fromInteger $2)) }
+ | '__U' inline_prag core_expr { HsUnfold $2 $3 }
+ | '__M' { HsCprInfo $1 }
+ | '__S' { HsStrictness (HsStrictnessInfo $1) }
| '__C' { HsNoCafRefs }
+ | '__P' qvar_name { HsWorker $2 }
-strict_info :: { [HsIdInfo RdrName] }
- : cpr worker { ($1:$2) }
- | strict worker { ($1:$2) }
- | cpr strict worker { ($1:$2:$3) }
-
-cpr :: { HsIdInfo RdrName }
- : '__M' { HsCprInfo $1 }
-
-strict :: { HsIdInfo RdrName }
- : '__S' { HsStrictness (HsStrictnessInfo $1) }
-
-worker :: { [HsIdInfo RdrName] }
- : qvar_name { [HsWorker $1] }
- | {- nothing -} { [] }
-
-arity_info :: { ArityInfo }
- : INTEGER { exactArity (fromInteger $1) }
+inline_prag :: { InlinePragInfo }
+ : {- empty -} { NoInlinePragInfo }
+ | '[' INTEGER ']' { IMustNotBeINLINEd True (Just (fromInteger $2)) } -- INLINE n
+ | '[' '!' INTEGER ']' { IMustNotBeINLINEd False (Just (fromInteger $3)) } -- NOINLINE n
-------------------------------------------------------
core_expr :: { UfExpr RdrName }
| core_lit { UfCon (UfLitCon $1) [] }
| '(' core_expr ')' { $2 }
| '(' comma_exprs2 ')' { UfTuple (mkTupConRdrName (length $2)) $2 }
- | '(#' core_expr '#)' { UfTuple (mkUbxTupConRdrName 1) [$2] }
- | '(#' comma_exprs2 '#)' { UfTuple (mkUbxTupConRdrName (length $2)) $2 }
+ | '(#' comma_exprs0 '#)' { UfTuple (mkUbxTupConRdrName (length $2)) $2 }
-- This one is dealt with by qdata_name: see above comments
-- | '(' ')' { UfTuple (mkTupConRdrName 0) [] }
+comma_exprs0 :: { [UfExpr RdrName] } -- Zero or more
+comma_exprs0 : {- empty -} { [ ] }
+ | core_expr { [ $1 ] }
+ | comma_exprs2 { $1 }
+
comma_exprs2 :: { [UfExpr RdrName] } -- Two or more
comma_exprs2 : core_expr ',' core_expr { [$1,$3] }
| core_expr ',' comma_exprs2 { $1 : $3 }
core_pat :: { (UfCon RdrName, [RdrName]) }
core_pat : core_lit { (UfLitCon $1, []) }
| '__litlit' STRING atype { (UfLitLitCon $2 $3, []) }
- | qdata_name var_names { (UfDataCon $1, $2) }
+ | qdata_name core_pat_names { (UfDataCon $1, $2) }
| '(' comma_var_names1 ')' { (UfDataCon (mkTupConRdrName (length $2)), $2) }
| '(#' comma_var_names1 '#)' { (UfDataCon (mkUbxTupConRdrName (length $2)), $2) }
| '__DEFAULT' { (UfDefault, []) }
| '(' core_pat ')' { $2 }
-
+core_pat_names :: { [RdrName] }
+core_pat_names : { [] }
+ | core_pat_name core_pat_names { $1 : $2 }
+
+-- Tyvar names and variable names live in different name spaces
+-- so they need to be signalled separately. But we don't record
+-- types or kinds in a pattern; we work that out from the type
+-- of the case scrutinee
+core_pat_name :: { RdrName }
+core_pat_name : var_name { $1 }
+ | '@' tv_name { $2 }
+
comma_var_names1 :: { [RdrName] } -- One or more
comma_var_names1 : var_name { [$1] }
| var_name ',' comma_var_names1 { $1 : $3 }
cc_name :: { EncodedFS }
: CONID { $1 }
- | VARID { $1 }
+ | var_fs { $1 }
cc_dup :: { IsDupdCC }
cc_dup : { OriginalCC }
| PIdInfo [HsIdInfo RdrName]
| PType RdrNameHsType
| PRules [RdrNameRuleDecl]
+ | PDeprecs [RdrNameDeprecation]
mkConDecl name (ex_tvs, ex_ctxt) details loc = ConDecl name ex_tvs ex_ctxt details loc
}