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
} ) }
--------------------------------------------------------------------------
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 }
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 }
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
}