ghc/compiler/rename/ParseIface.y

   1 {
   2 #include "HsVersions.h"
   3
   4 module ParseIface ( parseIface ) where
   5
   6 IMP_Ubiq(){-uitous-}
   7
   8 import ParseUtils
   9
  10 import HsSyn            -- quite a bit of stuff
  11 import RdrHsSyn         -- oodles of synonyms
  12 import HsPragmas        ( noGenPragmas )
  13
  14 import Bag              ( emptyBag, unitBag, snocBag )
  15 import FiniteMap        ( emptyFM, unitFM, addToFM, plusFM, bagToFM )
  16 import Name             ( ExportFlag(..), mkTupNameStr,
  17                           RdrName(..){-instance Outputable:ToDo:rm-}
  18                         )
  19 import Outputable       -- ToDo:rm
  20 import PprStyle         ( PprStyle(..) ) -- ToDo: rm debugging
  21 import SrcLoc           ( mkIfaceSrcLoc )
  22 import Util             ( panic, pprPanic{-ToDo:rm-} )
  23
  24 -----------------------------------------------------------------
  25
  26 parseIface = parseIToks . lexIface
  27
  28 -----------------------------------------------------------------
  29 }
  30
  31 %name       parseIToks
  32 %tokentype  { IfaceToken }
  33 %monad      { IfM }{ thenIf }{ returnIf }
  34
  35 %token
  36         INTERFACE           { ITinterface }
  37         USAGES_PART         { ITusages }
  38         VERSIONS_PART       { ITversions }
  39         EXPORTS_PART        { ITexports }
  40         INSTANCE_MODULES_PART { ITinstance_modules }
  41         INSTANCES_PART      { ITinstances }
  42         FIXITIES_PART       { ITfixities }
  43         DECLARATIONS_PART   { ITdeclarations }
  44         PRAGMAS_PART        { ITpragmas }
  45         BANG                { ITbang }
  46         BQUOTE              { ITbquote }
  47         CBRACK              { ITcbrack }
  48         CCURLY              { ITccurly }
  49         CLASS               { ITclass }
  50         COMMA               { ITcomma }
  51         CPAREN              { ITcparen }
  52         DARROW              { ITdarrow }
  53         DATA                { ITdata }
  54         DCOLON              { ITdcolon }
  55         DOTDOT              { ITdotdot }
  56         EQUAL               { ITequal }
  57         INFIX               { ITinfix }
  58         INFIXL              { ITinfixl }
  59         INFIXR              { ITinfixr }
  60         INSTANCE            { ITinstance }
  61         NEWTYPE             { ITnewtype }
  62         OBRACK              { ITobrack }
  63         OCURLY              { ITocurly }
  64         OPAREN              { IToparen }
  65         RARROW              { ITrarrow }
  66         SEMI                { ITsemi }
  67         TYPE                { ITtype }
  68         VBAR                { ITvbar }
  69         WHERE               { ITwhere }
  70         INTEGER             { ITinteger  $$ }
  71         VARID               { ITvarid    $$ }
  72         CONID               { ITconid    $$ }
  73         VARSYM              { ITvarsym   $$ }
  74         CONSYM              { ITconsym   $$ }
  75         QVARID              { ITqvarid   $$ }
  76         QCONID              { ITqconid   $$ }
  77         QVARSYM             { ITqvarsym  $$ }
  78         QCONSYM             { ITqconsym  $$ }
  79 %%
  80
  81 iface           :: { ParsedIface }
  82 iface           : INTERFACE CONID INTEGER
  83                   usages_part versions_part
  84                   exports_part inst_modules_part
  85                   fixities_part decls_part instances_part pragmas_part
  86                   { case $9 of { (tm, vm) ->
  87                     ParsedIface $2 (panic "merge modules") (fromInteger $3) Nothing{-src version-}
  88                         $4  -- usages
  89                         $5  -- local versions
  90                         $6  -- exports map
  91                         $7  -- instance modules
  92                         $8  -- fixities map
  93                         tm  -- decls maps
  94                         vm
  95                         $10  -- local instances
  96                         $11 -- pragmas map
  97                     }
  98 --------------------------------------------------------------------------
  99                   }
 100
 101 usages_part         :: { UsagesMap }
 102 usages_part         :  USAGES_PART module_stuff_pairs   { bagToFM $2 }
 103                     |                                   { emptyFM }
 104
 105 versions_part       :: { VersionsMap }
 106 versions_part       :  VERSIONS_PART name_version_pairs { bagToFM $2 }
 107                     |                                   { emptyFM }
 108
 109 module_stuff_pairs  :: { Bag (Module, (Version, FiniteMap FAST_STRING Version)) }
 110 module_stuff_pairs  :  module_stuff_pair
 111                         { unitBag $1 }
 112                     |  module_stuff_pairs module_stuff_pair
 113                         { $1 `snocBag` $2 }
 114
 115 module_stuff_pair   ::  { (Module, (Version, FiniteMap FAST_STRING Version)) }
 116 module_stuff_pair   :  CONID INTEGER DCOLON name_version_pairs SEMI
 117                         { ($1, (fromInteger $2, bagToFM $4)) }
 118
 119 name_version_pairs  ::  { Bag (FAST_STRING, Int) }
 120 name_version_pairs  :  name_version_pair
 121                         { unitBag $1 }
 122                     |  name_version_pairs name_version_pair
 123                         { $1 `snocBag` $2 }
 124
 125 name_version_pair   ::  { (FAST_STRING, Int) }
 126 name_version_pair   :  iname INTEGER
 127                         { ($1, fromInteger $2)
 128 --------------------------------------------------------------------------
 129                         }
 130
 131 exports_part    :: { ExportsMap }
 132 exports_part    :  EXPORTS_PART export_items { bagToFM $2 }
 133                 |                            { emptyFM }
 134
 135 export_items    :: { Bag (FAST_STRING, (RdrName, ExportFlag)) }
 136 export_items    :  export_item              { unitBag $1 }
 137                 |  export_items export_item { $1 `snocBag` $2 }
 138
 139 export_item     :: { (FAST_STRING, (RdrName, ExportFlag)) }
 140 export_item     :  qiname maybe_dotdot      { (de_qual $1, ($1, $2)) }
 141
 142 maybe_dotdot    :: { ExportFlag }
 143 maybe_dotdot    :  DOTDOT { ExportAll }
 144                 |         { ExportAbs
 145 --------------------------------------------------------------------------
 146                           }
 147
 148 inst_modules_part :: { Bag Module }
 149 inst_modules_part :  INSTANCE_MODULES_PART mod_list { $2 }
 150                   |                                 { emptyBag }
 151
 152 mod_list        :: { Bag Module }
 153 mod_list        :  CONID          { unitBag $1 }
 154                 |  mod_list CONID { $1 `snocBag` $2
 155 --------------------------------------------------------------------------
 156                                   }
 157
 158 fixities_part   :: { FixitiesMap }
 159 fixities_part   :  FIXITIES_PART fixes  { $2 }
 160                 |                       { emptyFM }
 161
 162 fixes           :: { FixitiesMap }
 163 fixes           :  fix          { case $1 of (k,v) -> unitFM k v }
 164                 |  fixes fix    { case $2 of (k,v) -> addToFM $1 k v }
 165
 166 fix             :: { (FAST_STRING, RdrNameFixityDecl) }
 167 fix             :  INFIXL INTEGER qop SEMI { (de_qual $3, InfixL $3 (fromInteger $2)) }
 168                 |  INFIXR INTEGER qop SEMI { (de_qual $3, InfixR $3 (fromInteger $2)) }
 169                 |  INFIX  INTEGER qop SEMI { (de_qual $3, InfixN $3 (fromInteger $2))
 170 --------------------------------------------------------------------------
 171                                       }
 172
 173 decls_part      :: { (LocalTyDefsMap, LocalValDefsMap) }
 174 decls_part      : DECLARATIONS_PART topdecls { $2 }
 175                 |                            { (emptyFM, emptyFM) }
 176
 177 topdecls        :: { (LocalTyDefsMap, LocalValDefsMap) }
 178 topdecls        :  topdecl          { $1 }
 179                 |  topdecls topdecl { case $1 of { (ts1, vs1) ->
 180                                       case $2 of { (ts2, vs2) ->
 181                                       (plusFM ts1 ts2, plusFM vs1 vs2)}}
 182                                      }
 183
 184 topdecl         :: { (LocalTyDefsMap, LocalValDefsMap) }
 185 topdecl         :  typed  SEMI  { ($1, emptyFM) }
 186                 |  datad  SEMI  { $1 }
 187                 |  newtd  SEMI  { $1 }
 188                 |  classd SEMI  { $1 }
 189                 |  decl         { case $1 of { (n, Sig qn ty _ loc) ->
 190                                   (emptyFM, unitFM n (ValSig qn loc ty)) }
 191                                 }
 192
 193 typed           :: { LocalTyDefsMap }
 194 typed           :  TYPE simple EQUAL type       { mk_type $2 $4 }
 195
 196 datad           :: { (LocalTyDefsMap, LocalValDefsMap) }
 197 datad           :  DATA                simple EQUAL constrs { mk_data [] $2 $4 }
 198                 |  DATA context DARROW simple EQUAL constrs { mk_data $2 $4 $6 }
 199
 200 newtd           :: { (LocalTyDefsMap, LocalValDefsMap) }
 201 newtd           :  NEWTYPE                simple EQUAL constr1 { mk_new [] $2 $4 }
 202                 |  NEWTYPE context DARROW simple EQUAL constr1 { mk_new $2 $4 $6 }
 203
 204 classd          :: { (LocalTyDefsMap, LocalValDefsMap) }
 205 classd          :  CLASS                class cbody { mk_class [] $2 $3 }
 206                 |  CLASS context DARROW class cbody { mk_class $2 $4 $5 }
 207
 208 cbody           :: { [(FAST_STRING, RdrNameSig)] }
 209 cbody           :  WHERE OCURLY decls CCURLY { $3 }
 210                 |                            { [] }
 211
 212 decls           :: { [(FAST_STRING, RdrNameSig)] }
 213 decls           : decl          { [$1] }
 214                 | decls decl    { $1 ++ [$2] }
 215
 216 decl            :: { (FAST_STRING, RdrNameSig) }
 217 decl            :  var DCOLON ctype SEMI { (de_qual $1, Sig $1 $3 noGenPragmas mkIfaceSrcLoc) }
 218
 219 context         :: { RdrNameContext }
 220 context         :  OPAREN context_list CPAREN   { reverse $2 }
 221                 |  class                        { [$1] }
 222
 223 context_list    :: { RdrNameContext{-reversed-} }
 224 context_list    :  class                        { [$1] }
 225                 |  context_list COMMA class     { $3 : $1 }
 226
 227 class           :: { (RdrName, RdrName) }
 228 class           :  gtycon VARID                 { ($1, Unqual $2) }
 229
 230 ctype           :: { RdrNamePolyType }
 231 ctype           : type DARROW type  { HsPreForAllTy (type2context $1) $3 }
 232                 | type              { HsPreForAllTy []                $1 }
 233
 234 type            :: { RdrNameMonoType }
 235 type            :  btype                { $1 }
 236                 |  btype RARROW type    { MonoFunTy $1 $3 }
 237
 238 types           :: { [RdrNameMonoType] }
 239 types           :  type                 { [$1] }
 240                 |  types COMMA type     { $1 ++ [$3] }
 241
 242 btype           :: { RdrNameMonoType }
 243 btype           :  gtyconapp            { case $1 of (tc, tys) -> MonoTyApp tc tys }
 244                 |  ntyconapp            { case $1 of { (ty1, tys) ->
 245                                           if null tys
 246                                           then ty1
 247                                           else
 248                                           case ty1 of {
 249                                             MonoTyVar tv    -> MonoTyApp tv tys;
 250                                             MonoTyApp tc ts -> MonoTyApp tc (ts++tys);
 251                                             MonoFunTy t1 t2 -> MonoTyApp (Unqual SLIT("->")) (t1:t2:tys);
 252                                             MonoListTy ty   -> MonoTyApp (Unqual SLIT("[]")) (ty:tys);
 253                                             MonoTupleTy ts  -> MonoTyApp (Unqual (mkTupNameStr (length ts)))
 254                                                                          (ts++tys);
 255                                             _               -> pprPanic "test:" (ppr PprDebug $1)
 256                                           }}
 257                                         }
 258
 259 ntyconapp       :: { (RdrNameMonoType, [RdrNameMonoType]) }
 260 ntyconapp       : ntycon                { ($1, []) }
 261                 | ntyconapp atype       { case $1 of (t1,tys) -> (t1, tys ++ [$2]) }
 262
 263 gtyconapp       :: { (RdrName, [RdrNameMonoType]) }
 264 gtyconapp       : gtycon                { ($1, []) }
 265                 | gtyconapp atype       { case $1 of (tc,tys) -> (tc, tys ++ [$2]) }
 266
 267 atype           :: { RdrNameMonoType }
 268 atype           :  gtycon               { MonoTyApp $1 [] }
 269                 |  ntycon               { $1 }
 270
 271 atypes          :: { [RdrNameMonoType] }
 272 atypes          :  atype                { [$1] }
 273                 |  atypes atype         { $1 ++ [$2] }
 274
 275 ntycon          :: { RdrNameMonoType }
 276 ntycon          :  VARID                          { MonoTyVar (Unqual $1) }
 277                 |  OPAREN type COMMA types CPAREN { MonoTupleTy ($2 : $4) }
 278                 |  OBRACK type CBRACK             { MonoListTy $2 }
 279                 |  OPAREN type CPAREN             { $2 }
 280
 281 gtycon          :: { RdrName }
 282 gtycon          :  QCONID               { $1 }
 283                 |  CONID                { Unqual $1 }
 284                 |  OPAREN RARROW CPAREN { Unqual SLIT("->") }
 285                 |  OBRACK CBRACK        { Unqual SLIT("[]") }
 286                 |  OPAREN CPAREN        { Unqual SLIT("()") }
 287                 |  OPAREN commas CPAREN { Unqual (mkTupNameStr $2) }
 288
 289 commas          :: { Int }
 290 commas          :  COMMA                { 2{-1 comma => arity 2-} }
 291                 |  commas COMMA         { $1 + 1 }
 292
 293 simple          :: { (RdrName, [FAST_STRING]) }
 294 simple          :  gtycon       { ($1, []) }
 295                 |  gtyconvars   { case $1 of (tc,tvs) -> (tc, reverse tvs) }
 296
 297 gtyconvars      :: { (RdrName, [FAST_STRING] {-reversed-}) }
 298 gtyconvars      :  gtycon     VARID { ($1, [$2]) }
 299                 |  gtyconvars VARID { case $1 of (tc,tvs) -> (tc, $2 : tvs) }
 300
 301 constrs         :: { [(RdrName, RdrNameConDecl)] }
 302 constrs         :  constr               { [$1] }
 303                 |  constrs VBAR constr  { $1 ++ [$3] }
 304
 305 constr          :: { (RdrName, RdrNameConDecl) }
 306 constr          :  btyconapp
 307                    { case $1 of (con, tys) -> (con, ConDecl con tys mkIfaceSrcLoc) }
 308                 |  OPAREN QCONSYM CPAREN         { ($2, ConDecl $2 [] mkIfaceSrcLoc) }
 309                 |  OPAREN QCONSYM CPAREN batypes { ($2, ConDecl $2 $4 mkIfaceSrcLoc) }
 310                 |  OPAREN CONSYM CPAREN          { (Unqual $2, ConDecl (Unqual $2) [] mkIfaceSrcLoc) }
 311                 |  OPAREN CONSYM CPAREN batypes  { (Unqual $2, ConDecl (Unqual $2) $4 mkIfaceSrcLoc) }
 312                 |  gtycon OCURLY fields CCURLY
 313                    { ($1, RecConDecl $1 $3 mkIfaceSrcLoc) }
 314
 315 btyconapp       :: { (RdrName, [RdrNameBangType]) }
 316 btyconapp       :  gtycon                       { ($1, []) }
 317                 |  btyconapp batype             { case $1 of (tc,tys) -> (tc, tys ++ [$2]) }
 318
 319 bbtype          :: { RdrNameBangType }
 320 bbtype          :  btype                        { Unbanged (HsPreForAllTy [] $1) }
 321                 |  BANG atype                   { Banged   (HsPreForAllTy [] $2) }
 322
 323 batype          :: { RdrNameBangType }
 324 batype          :  atype                        { Unbanged (HsPreForAllTy [] $1) }
 325                 |  BANG atype                   { Banged   (HsPreForAllTy [] $2) }
 326
 327 batypes         :: { [RdrNameBangType] }
 328 batypes         :  batype                       { [$1] }
 329                 |  batypes batype               { $1 ++ [$2] }
 330
 331 fields          :: { [([RdrName], RdrNameBangType)] }
 332 fields          : field                         { [$1] }
 333                 | fields COMMA field            { $1 ++ [$3] }
 334
 335 field           :: { ([RdrName], RdrNameBangType) }
 336 field           :  var DCOLON type          { ([$1], Unbanged (HsPreForAllTy [] $3)) }
 337                 |  var DCOLON BANG atype    { ([$1], Banged   (HsPreForAllTy [] $4)) }
 338
 339 constr1         :: { (RdrName, RdrNameMonoType) }
 340 constr1         :  gtycon atype { ($1, $2) }
 341
 342 var             :: { RdrName }
 343 var             :  QVARID                { $1 }
 344                 |  OPAREN QVARSYM CPAREN { $2 }
 345                 |  VARID                 { Unqual $1 }
 346                 |  OPAREN VARSYM CPAREN  { Unqual $2 }
 347
 348 op              :: { FAST_STRING }
 349 op              :  BQUOTE VARID BQUOTE  { $2 }
 350                 |  BQUOTE CONID BQUOTE  { $2 }
 351                 |  VARSYM               { $1 }
 352                 |  CONSYM               { $1 }
 353
 354 qop             :: { RdrName }
 355 qop             :  BQUOTE QVARID BQUOTE { $2 }
 356                 |  BQUOTE QCONID BQUOTE { $2 }
 357                 |  QVARSYM              { $1 }
 358                 |  QCONSYM              { $1 }
 359                 |  op                   { Unqual $1 }
 360
 361 iname           :: { FAST_STRING }
 362 iname           :  VARID                { $1 }
 363                 |  CONID                { $1 }
 364                 |  OPAREN VARSYM CPAREN { $2 }
 365                 |  OPAREN BANG   CPAREN { SLIT("!"){-sigh, double-sigh-} }
 366                 |  OPAREN CONSYM CPAREN { $2 }
 367
 368 qiname          :: { RdrName }
 369 qiname          :  QVARID                   { $1 }
 370                 |  QCONID                   { $1 }
 371                 |  OPAREN QVARSYM CPAREN    { $2 }
 372                 |  OPAREN QCONSYM CPAREN    { $2 }
 373                 |  iname                    { Unqual $1 }
 374
 375 instances_part  :: { Bag RdrIfaceInst }
 376 instances_part  :  INSTANCES_PART instdecls { $2 }
 377                 |                           { emptyBag }
 378
 379 instdecls       :: { Bag RdrIfaceInst }
 380 instdecls       :  instd                    { unitBag $1 }
 381                 |  instdecls instd          { $1 `snocBag` $2 }
 382
 383 instd           :: { RdrIfaceInst }
 384 instd           :  INSTANCE context DARROW gtycon restrict_inst SEMI { mk_inst $2 $4 $5 }
 385                 |  INSTANCE                gtycon general_inst  SEMI { mk_inst [] $2 $3 }
 386
 387 restrict_inst   :: { RdrNameMonoType }
 388 restrict_inst   :  gtycon                               { MonoTyApp $1 [] }
 389                 |  OPAREN gtyconvars CPAREN             { case $2 of (tc,tvs) -> MonoTyApp tc (map en_mono tvs) }
 390                 |  OPAREN VARID COMMA tyvar_list CPAREN { MonoTupleTy (map en_mono ($2:$4)) }
 391                 |  OBRACK VARID CBRACK                  { MonoListTy (en_mono $2) }
 392                 |  OPAREN VARID RARROW VARID CPAREN     { MonoFunTy (en_mono $2) (en_mono $4) }
 393
 394 general_inst    :: { RdrNameMonoType }
 395 general_inst    :  gtycon                               { MonoTyApp $1 [] }
 396                 |  OPAREN gtyconapp CPAREN              { case $2 of (tc,tys) -> MonoTyApp tc tys }
 397                 |  OPAREN type COMMA types CPAREN       { MonoTupleTy ($2:$4) }
 398                 |  OBRACK type CBRACK                   { MonoListTy $2 }
 399                 |  OPAREN btype RARROW type CPAREN      { MonoFunTy $2 $4 }
 400
 401 tyvar_list      :: { [FAST_STRING] }
 402 tyvar_list      :  VARID                    { [$1] }
 403                 |  tyvar_list COMMA VARID   { $1 ++ [$3]
 404 --------------------------------------------------------------------------
 405                                             }
 406
 407 pragmas_part    :: { LocalPragmasMap }
 408 pragmas_part    :  PRAGMAS_PART
 409                    { emptyFM }
 410                 |  { emptyFM }
 411 {
 412 }