ghc/compiler/rename/ParseIface.y

   1 {
   2 #include "HsVersions.h"
   3
   4 module ParseIface ( parseIface ) where
   5
   6 import 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             ( 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 (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 COMMA name_version_pair
 123                         { $1 `snocBag` $3 }
 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
 134 export_items    :: { Bag (FAST_STRING, (RdrName, ExportFlag)) }
 135 export_items    :  export_item              { unitBag $1 }
 136                 |  export_items export_item { $1 `snocBag` $2 }
 137
 138 export_item     :: { (FAST_STRING, (RdrName, ExportFlag)) }
 139 export_item     :  qiname maybe_dotdot      { (de_qual $1, ($1, $2)) }
 140
 141 maybe_dotdot    :: { ExportFlag }
 142 maybe_dotdot    :  DOTDOT { ExportAll }
 143                 |         { ExportAbs
 144 --------------------------------------------------------------------------
 145                           }
 146
 147 inst_modules_part :: { Bag Module }
 148 inst_modules_part :  INSTANCE_MODULES_PART mod_list { $2 }
 149                   |                                 { emptyBag }
 150
 151 mod_list        :: { Bag Module }
 152 mod_list        :  CONID          { unitBag $1 }
 153                 |  mod_list CONID { $1 `snocBag` $2
 154 --------------------------------------------------------------------------
 155                                   }
 156
 157 fixities_part   :: { FixitiesMap }
 158 fixities_part   :  FIXITIES_PART fixes  { $2 }
 159                 |                       { emptyFM }
 160
 161 fixes           :: { FixitiesMap }
 162 fixes           :  fix          { case $1 of (k,v) -> unitFM k v }
 163                 |  fixes fix    { case $2 of (k,v) -> addToFM $1 k v }
 164
 165 fix             :: { (FAST_STRING, RdrNameFixityDecl) }
 166 fix             :  INFIXL INTEGER qop SEMI { (de_qual $3, InfixL $3 (fromInteger $2)) }
 167                 |  INFIXR INTEGER qop SEMI { (de_qual $3, InfixR $3 (fromInteger $2)) }
 168                 |  INFIX  INTEGER qop SEMI { (de_qual $3, InfixN $3 (fromInteger $2))
 169 --------------------------------------------------------------------------
 170                                       }
 171
 172 decls_part      :: { (LocalTyDefsMap, LocalValDefsMap) }
 173 decls_part      : DECLARATIONS_PART topdecls { $2 }
 174
 175 topdecls        :: { (LocalTyDefsMap, LocalValDefsMap) }
 176 topdecls        :  topdecl          { $1 }
 177                 |  topdecls topdecl { case $1 of { (ts1, vs1) ->
 178                                       case $2 of { (ts2, vs2) ->
 179                                       (plusFM ts1 ts2, plusFM vs1 vs2)}}
 180                                      }
 181
 182 topdecl         :: { (LocalTyDefsMap, LocalValDefsMap) }
 183 topdecl         :  typed  SEMI  { ($1, emptyFM) }
 184                 |  datad  SEMI  { $1 }
 185                 |  newtd  SEMI  { $1 }
 186                 |  classd SEMI  { $1 }
 187                 |  decl         { case $1 of { (n, Sig qn ty _ loc) ->
 188                                   (emptyFM, unitFM n (ValSig qn loc ty)) }
 189                                 }
 190
 191 typed           :: { LocalTyDefsMap }
 192 typed           :  TYPE simple EQUAL type       { mk_type $2 $4 }
 193
 194 datad           :: { (LocalTyDefsMap, LocalValDefsMap) }
 195 datad           :  DATA                simple EQUAL constrs { mk_data [] $2 $4 }
 196                 |  DATA context DARROW simple EQUAL constrs { mk_data $2 $4 $6 }
 197
 198 newtd           :: { (LocalTyDefsMap, LocalValDefsMap) }
 199 newtd           :  NEWTYPE                simple EQUAL constr1 { mk_new [] $2 $4 }
 200                 |  NEWTYPE context DARROW simple EQUAL constr1 { mk_new $2 $4 $6 }
 201
 202 classd          :: { (LocalTyDefsMap, LocalValDefsMap) }
 203 classd          :  CLASS                class cbody { mk_class [] $2 $3 }
 204                 |  CLASS context DARROW class cbody { mk_class $2 $4 $5 }
 205
 206 cbody           :: { [(FAST_STRING, RdrNameSig)] }
 207 cbody           :  WHERE OCURLY decls CCURLY { $3 }
 208                 |                            { [] }
 209
 210 decls           :: { [(FAST_STRING, RdrNameSig)] }
 211 decls           : decl          { [$1] }
 212                 | decls decl    { $1 ++ [$2] }
 213
 214 decl            :: { (FAST_STRING, RdrNameSig) }
 215 decl            :  var DCOLON ctype SEMI { (de_qual $1, Sig $1 $3 noGenPragmas mkIfaceSrcLoc) }
 216
 217 context         :: { RdrNameContext }
 218 context         :  OPAREN context_list CPAREN   { reverse $2 }
 219                 |  class                        { [$1] }
 220
 221 context_list    :: { RdrNameContext{-reversed-} }
 222 context_list    :  class                        { [$1] }
 223                 |  context_list COMMA class     { $3 : $1 }
 224
 225 class           :: { (RdrName, RdrName) }
 226 class           :  gtycon VARID                 { ($1, Unqual $2) }
 227
 228 ctype           :: { RdrNamePolyType }
 229 ctype           : type DARROW type  { HsPreForAllTy (type2context $1) $3 }
 230                 | type              { HsPreForAllTy []                $1 }
 231
 232 type            :: { RdrNameMonoType }
 233 type            :  btype                { $1 }
 234                 |  btype RARROW type    { MonoFunTy $1 $3 }
 235
 236 types           :: { [RdrNameMonoType] }
 237 types           :  type                 { [$1] }
 238                 |  types COMMA type     { $1 ++ [$3] }
 239
 240 btype           :: { RdrNameMonoType }
 241 btype           :  gtyconapp            { case $1 of (tc, tys) -> MonoTyApp tc tys }
 242                 |  ntyconapp            { case $1 of { (ty1, tys) ->
 243                                           if null tys
 244                                           then ty1
 245                                           else
 246                                           case ty1 of {
 247                                             MonoTyVar tv    -> MonoTyApp tv tys;
 248                                             MonoTyApp tc ts -> MonoTyApp tc (ts++tys);
 249                                             MonoFunTy t1 t2 -> MonoTyApp (Unqual SLIT("->")) (t1:t2:tys);
 250                                             MonoListTy ty   -> MonoTyApp (Unqual SLIT("[]")) (ty:tys);
 251                                             MonoTupleTy ts  -> MonoTyApp (Unqual (mkTupNameStr (length ts)))
 252                                                                          (ts++tys);
 253                                             _               -> pprPanic "test:" (ppr PprDebug $1)
 254                                           }}
 255                                         }
 256
 257 ntyconapp       :: { (RdrNameMonoType, [RdrNameMonoType]) }
 258 ntyconapp       : ntycon                { ($1, []) }
 259                 | ntyconapp atype       { case $1 of (t1,tys) -> (t1, tys ++ [$2]) }
 260
 261 gtyconapp       :: { (RdrName, [RdrNameMonoType]) }
 262 gtyconapp       : gtycon                { ($1, []) }
 263                 | gtyconapp atype       { case $1 of (tc,tys) -> (tc, tys ++ [$2]) }
 264
 265 atype           :: { RdrNameMonoType }
 266 atype           :  gtycon               { MonoTyApp $1 [] }
 267                 |  ntycon               { $1 }
 268
 269 atypes          :: { [RdrNameMonoType] }
 270 atypes          :  atype                { [$1] }
 271                 |  atypes atype         { $1 ++ [$2] }
 272
 273 ntycon          :: { RdrNameMonoType }
 274 ntycon          :  VARID                          { MonoTyVar (Unqual $1) }
 275                 |  OPAREN type COMMA types CPAREN { MonoTupleTy ($2 : $4) }
 276                 |  OBRACK type CBRACK             { MonoListTy $2 }
 277                 |  OPAREN type CPAREN             { $2 }
 278
 279 gtycon          :: { RdrName }
 280 gtycon          :  QCONID               { $1 }
 281                 |  CONID                { Unqual $1 }
 282                 |  OPAREN RARROW CPAREN { Unqual SLIT("->") }
 283                 |  OBRACK CBRACK        { Unqual SLIT("[]") }
 284                 |  OPAREN CPAREN        { Unqual SLIT("()") }
 285                 |  OPAREN commas CPAREN { Unqual (mkTupNameStr $2) }
 286
 287 commas          :: { Int }
 288 commas          :  COMMA                { 2{-1 comma => arity 2-} }
 289                 |  commas COMMA         { $1 + 1 }
 290
 291 simple          :: { (RdrName, [FAST_STRING]) }
 292 simple          :  gtycon       { ($1, []) }
 293                 |  gtyconvars   { case $1 of (tc,tvs) -> (tc, reverse tvs) }
 294
 295 gtyconvars      :: { (RdrName, [FAST_STRING] {-reversed-}) }
 296 gtyconvars      :  gtycon     VARID { ($1, [$2]) }
 297                 |  gtyconvars VARID { case $1 of (tc,tvs) -> (tc, $2 : tvs) }
 298
 299 constrs         :: { [(RdrName, RdrNameConDecl)] }
 300 constrs         :  constr               { [$1] }
 301                 |  constrs VBAR constr  { $1 ++ [$3] }
 302
 303 constr          :: { (RdrName, RdrNameConDecl) }
 304 constr          :  btyconapp
 305                    { case $1 of (con, tys) -> (con, ConDecl con tys mkIfaceSrcLoc) }
 306                 |  OPAREN QCONSYM CPAREN         { ($2, ConDecl $2 [] mkIfaceSrcLoc) }
 307                 |  OPAREN QCONSYM CPAREN batypes { ($2, ConDecl $2 $4 mkIfaceSrcLoc) }
 308                 |  OPAREN CONSYM CPAREN          { (Unqual $2, ConDecl (Unqual $2) [] mkIfaceSrcLoc) }
 309                 |  OPAREN CONSYM CPAREN batypes  { (Unqual $2, ConDecl (Unqual $2) $4 mkIfaceSrcLoc) }
 310                 |  gtycon OCURLY fields CCURLY
 311                    { ($1, RecConDecl $1 $3 mkIfaceSrcLoc) }
 312
 313 btyconapp       :: { (RdrName, [RdrNameBangType]) }
 314 btyconapp       :  gtycon                       { ($1, []) }
 315                 |  btyconapp batype             { case $1 of (tc,tys) -> (tc, tys ++ [$2]) }
 316
 317 bbtype          :: { RdrNameBangType }
 318 bbtype          :  btype                        { Unbanged (HsPreForAllTy [] $1) }
 319                 |  BANG atype                   { Banged   (HsPreForAllTy [] $2) }
 320
 321 batype          :: { RdrNameBangType }
 322 batype          :  atype                        { Unbanged (HsPreForAllTy [] $1) }
 323                 |  BANG atype                   { Banged   (HsPreForAllTy [] $2) }
 324
 325 batypes         :: { [RdrNameBangType] }
 326 batypes         :  batype                       { [$1] }
 327                 |  batypes batype               { $1 ++ [$2] }
 328
 329 fields          :: { [([RdrName], RdrNameBangType)] }
 330 fields          : field                         { [$1] }
 331                 | fields COMMA field            { $1 ++ [$3] }
 332
 333 field           :: { ([RdrName], RdrNameBangType) }
 334 field           :  var DCOLON type          { ([$1], Unbanged (HsPreForAllTy [] $3)) }
 335                 |  var DCOLON BANG atype    { ([$1], Banged   (HsPreForAllTy [] $4)) }
 336
 337 constr1         :: { (RdrName, RdrNameMonoType) }
 338 constr1         :  gtycon atype { ($1, $2) }
 339
 340 var             :: { RdrName }
 341 var             :  QVARID                { $1 }
 342                 |  OPAREN QVARSYM CPAREN { $2 }
 343                 |  VARID                 { Unqual $1 }
 344                 |  OPAREN VARSYM CPAREN  { Unqual $2 }
 345
 346 op              :: { FAST_STRING }
 347 op              :  BQUOTE VARID BQUOTE  { $2 }
 348                 |  BQUOTE CONID BQUOTE  { $2 }
 349                 |  VARSYM               { $1 }
 350                 |  CONSYM               { $1 }
 351
 352 qop             :: { RdrName }
 353 qop             :  BQUOTE QVARID BQUOTE { $2 }
 354                 |  BQUOTE QCONID BQUOTE { $2 }
 355                 |  QVARSYM              { $1 }
 356                 |  QCONSYM              { $1 }
 357                 |  op                   { Unqual $1 }
 358
 359 iname           :: { FAST_STRING }
 360 iname           :  VARID                { $1 }
 361                 |  CONID                { $1 }
 362                 |  OPAREN VARSYM CPAREN { $2 }
 363                 |  OPAREN CONSYM CPAREN { $2 }
 364
 365 qiname          :: { RdrName }
 366 qiname          :  QVARID                   { $1 }
 367                 |  QCONID                   { $1 }
 368                 |  OPAREN QVARSYM CPAREN    { $2 }
 369                 |  OPAREN QCONSYM CPAREN    { $2 }
 370                 |  iname                    { Unqual $1 }
 371
 372 instances_part  :: { Bag RdrIfaceInst }
 373 instances_part  :  INSTANCES_PART instdecls { $2 }
 374                 |                           { emptyBag }
 375
 376 instdecls       :: { Bag RdrIfaceInst }
 377 instdecls       :  instd                    { unitBag $1 }
 378                 |  instdecls instd          { $1 `snocBag` $2 }
 379
 380 instd           :: { RdrIfaceInst }
 381 instd           :  INSTANCE context DARROW gtycon restrict_inst SEMI { mk_inst $2 $4 $5 }
 382                 |  INSTANCE                gtycon general_inst  SEMI { mk_inst [] $2 $3 }
 383
 384 restrict_inst   :: { RdrNameMonoType }
 385 restrict_inst   :  gtycon                               { MonoTyApp $1 [] }
 386                 |  OPAREN gtyconvars CPAREN             { case $2 of (tc,tvs) -> MonoTyApp tc (map en_mono tvs) }
 387                 |  OPAREN VARID COMMA tyvar_list CPAREN { MonoTupleTy (map en_mono ($2:$4)) }
 388                 |  OBRACK VARID CBRACK                  { MonoListTy (en_mono $2) }
 389                 |  OPAREN VARID RARROW VARID CPAREN     { MonoFunTy (en_mono $2) (en_mono $4) }
 390
 391 general_inst    :: { RdrNameMonoType }
 392 general_inst    :  gtycon                               { MonoTyApp $1 [] }
 393                 |  OPAREN gtyconapp CPAREN              { case $2 of (tc,tys) -> MonoTyApp tc tys }
 394                 |  OPAREN type COMMA types CPAREN       { MonoTupleTy ($2:$4) }
 395                 |  OBRACK type CBRACK                   { MonoListTy $2 }
 396                 |  OPAREN btype RARROW type CPAREN      { MonoFunTy $2 $4 }
 397
 398 tyvar_list      :: { [FAST_STRING] }
 399 tyvar_list      :  VARID                    { [$1] }
 400                 |  tyvar_list COMMA VARID   { $1 ++ [$3]
 401 --------------------------------------------------------------------------
 402                                             }
 403
 404 pragmas_part    :: { LocalPragmasMap }
 405 pragmas_part    :  PRAGMAS_PART
 406                    { emptyFM }
 407                 |  { emptyFM }
 408 {
 409 }