import RdrName ( RdrName, mkRdrUnqual, mkSysQual, mkSysUnqual )
import Name ( OccName, Provenance )
import OccName ( mkSysOccFS,
- tcName, varName, dataName, clsName, tvName, uvName,
+ 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 }
'__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 }
+ | data_name { IEThingAbs $1 }
+
+-----------------------------------------------------------------------------
+
version :: { Version }
version : INTEGER { fromInteger $1 }
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 -} { [ ] }
| '(#' 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 }
| 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 }
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
}
projects / ghc-hetmet.git / blobdiff