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