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