ghc/compiler/rename/ParseUnfolding.y

   1 {
   2 #include "HsVersions.h"
   3 module ParseUnfolding ( parseUnfolding ) where
   4
   5 IMP_Ubiq(){-uitous-}
   6
   7 import HsSyn            -- quite a bit of stuff
   8 import RdrHsSyn         -- oodles of synonyms
   9 import HsDecls          ( HsIdInfo(..) )
  10 import HsTypes          ( mkHsForAllTy )
  11 import HsCore
  12 import Literal
  13 import PrimRep          ( decodePrimRep )
  14 import HsPragmas        ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas )
  15 import IdInfo           ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo,
  16                           ArgUsageInfo, FBTypeInfo, ArityInfo, StrictnessInfo
  17                         )
  18 import Kind             ( Kind, mkArrowKind, mkTypeKind )
  19 import Lex
  20
  21 import RnMonad          ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..),
  22                           SYN_IE(RdrNamePragma), SYN_IE(ExportItem)
  23                         )
  24 import Bag              ( emptyBag, unitBag, snocBag )
  25 import FiniteMap        ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
  26 import Name             ( OccName(..), isTCOcc, Provenance, SYN_IE(Module) )
  27 import SrcLoc           ( mkIfaceSrcLoc )
  28 import Util             ( panic{-, pprPanic ToDo:rm-} )
  29 import Pretty           ( Doc )
  30 import PprStyle         -- PprDebug for panic
  31 import Maybes           ( MaybeErr(..) )
  32
  33 ------------------------------------------------------------------
  34
  35 parseUnfolding ls =
  36   let
  37    res =
  38     case parseUnfold ls of
  39       v@(Succeeded _) -> v
  40         -- ill-formed unfolding, crash and burn.
  41       Failed err      -> panic (show (err PprDebug))
  42   in
  43   res
  44 }
  45
  46 %name parseUnfold
  47 %tokentype { IfaceToken }
  48 %monad      { IfM }{ thenIf }{ returnIf }
  49
  50 %token
  51         PRAGMAS_PART        { ITpragmas }
  52         DATA                { ITdata }
  53         TYPE                { ITtype }
  54         NEWTYPE             { ITnewtype }
  55         DERIVING            { ITderiving }
  56         CLASS               { ITclass }
  57         WHERE               { ITwhere }
  58         INSTANCE            { ITinstance }
  59         FORALL              { ITforall }
  60         BANG                { ITbang }
  61         VBAR                { ITvbar }
  62         DCOLON              { ITdcolon }
  63         COMMA               { ITcomma }
  64         DARROW              { ITdarrow }
  65         DOTDOT              { ITdotdot }
  66         EQUAL               { ITequal }
  67         OCURLY              { ITocurly }
  68         OBRACK              { ITobrack }
  69         OPAREN              { IToparen }
  70         RARROW              { ITrarrow }
  71         CCURLY              { ITccurly }
  72         CBRACK              { ITcbrack }
  73         CPAREN              { ITcparen }
  74         SEMI                { ITsemi }
  75
  76         VARID               { ITvarid    $$ }
  77         CONID               { ITconid    $$ }
  78         VARSYM              { ITvarsym   $$ }
  79         CONSYM              { ITconsym   $$ }
  80         QVARID              { ITqvarid   $$ }
  81         QCONID              { ITqconid   $$ }
  82         QVARSYM             { ITqvarsym  $$ }
  83         QCONSYM             { ITqconsym  $$ }
  84
  85         ARITY_PART      { ITarity }
  86         STRICT_PART     { ITstrict }
  87         UNFOLD_PART     { ITunfold }
  88         DEMAND          { ITdemand $$ }
  89         BOTTOM          { ITbottom }
  90         LAM             { ITlam }
  91         BIGLAM          { ITbiglam }
  92         CASE            { ITcase }
  93         PRIM_CASE       { ITprim_case }
  94         LET             { ITlet }
  95         LETREC          { ITletrec }
  96         IN              { ITin }
  97         OF              { ITof }
  98         COERCE_IN       { ITcoerce_in }
  99         COERCE_OUT      { ITcoerce_out }
 100         ATSIGN          { ITatsign }
 101         CCALL           { ITccall $$ }
 102         SCC             { ITscc $$ }
 103
 104         CHAR            { ITchar $$ }
 105         STRING          { ITstring $$ }
 106         INTEGER         { ITinteger  $$ }
 107         DOUBLE          { ITdouble $$ }
 108
 109         INTEGER_LIT     { ITinteger_lit }
 110         FLOAT_LIT       { ITfloat_lit }
 111         RATIONAL_LIT    { ITrational_lit }
 112         ADDR_LIT        { ITaddr_lit }
 113         LIT_LIT         { ITlit_lit }
 114         STRING_LIT      { ITstring_lit }
 115
 116         UNKNOWN         { ITunknown $$ }
 117 %%
 118
 119 id_info         :: { [HsIdInfo RdrName] }
 120 id_info         :                                               { [] }
 121                 | id_info_item id_info                          { $1 : $2 }
 122
 123 id_info_item    :: { HsIdInfo RdrName }
 124 id_info_item    : ARITY_PART arity_info                 { HsArity $2 }
 125                 | STRICT_PART strict_info               { HsStrictness $2 }
 126                 | BOTTOM                                { HsStrictness mkBottomStrictnessInfo }
 127                 | UNFOLD_PART core_expr                 { HsUnfold $2 }
 128
 129 arity_info      :: { ArityInfo }
 130 arity_info      : INTEGER                                       { exactArity (fromInteger $1) }
 131
 132 strict_info     :: { StrictnessInfo RdrName }
 133 strict_info     : DEMAND any_var_name                           { mkStrictnessInfo $1 (Just $2) }
 134                 | DEMAND                                        { mkStrictnessInfo $1 Nothing }
 135
 136 core_expr       :: { UfExpr RdrName }
 137 core_expr       : any_var_name                                  { UfVar $1 }
 138                 | data_name                                     { UfVar $1 }
 139                 | core_lit                                      { UfLit $1 }
 140                 | OPAREN core_expr CPAREN                       { $2 }
 141                 | data_name OCURLY data_args CCURLY             { UfCon $1 $3 }
 142
 143                 | core_expr ATSIGN atype                        { UfApp $1 (UfTyArg $3) }
 144                 | core_expr core_arg                            { UfApp $1 $2 }
 145                 | LAM core_val_bndrs RARROW core_expr           { foldr UfLam $4 $2 }
 146                 | BIGLAM core_tv_bndrs RARROW core_expr         { foldr UfLam $4 $2 }
 147
 148                 | CASE core_expr OF
 149                   OCURLY alg_alts core_default CCURLY           { UfCase $2 (UfAlgAlts  $5 $6) }
 150                 | PRIM_CASE core_expr OF
 151                   OCURLY prim_alts core_default CCURLY          { UfCase $2 (UfPrimAlts $5 $6) }
 152
 153
 154                 | LET OCURLY core_val_bndr EQUAL core_expr CCURLY
 155                   IN core_expr                                  { UfLet (UfNonRec $3 $5) $8 }
 156                 | LETREC OCURLY rec_binds CCURLY
 157                   IN core_expr                                  { UfLet (UfRec $3) $6 }
 158
 159                 | coerce atype core_expr                        { UfCoerce $1 $2 $3 }
 160
 161                 | CCALL ccall_string
 162                         OBRACK atype atypes CBRACK core_args    { let
 163                                                                         (is_casm, may_gc) = $1
 164                                                                   in
 165                                                                   UfPrim (UfCCallOp $2 is_casm may_gc $5 $4)
 166                                                                          $7
 167                                                                 }
 168                 | SCC core_expr                                 {  UfSCC $1 $2  }
 169
 170 rec_binds       :: { [(UfBinder RdrName, UfExpr RdrName)] }
 171                 :                                               { [] }
 172                 | core_val_bndr EQUAL core_expr SEMI rec_binds  { ($1,$3) : $5 }
 173
 174 coerce          :: { UfCoercion RdrName }
 175 coerce          : COERCE_IN  data_name                          { UfIn  $2 }
 176                 | COERCE_OUT data_name                          { UfOut $2 }
 177
 178 prim_alts       :: { [(Literal,UfExpr RdrName)] }
 179                 :                                               { [] }
 180                 | core_lit RARROW core_expr SEMI prim_alts      { ($1,$3) : $5 }
 181
 182 alg_alts        :: { [(RdrName, [RdrName], UfExpr RdrName)] }
 183                 :                                               { [] }
 184                 | data_name var_names RARROW
 185                         core_expr SEMI alg_alts                 { ($1,$2,$4) : $6 }
 186
 187 core_default    :: { UfDefault RdrName }
 188                 :                                               { UfNoDefault }
 189                 | var_name RARROW core_expr SEMI                { UfBindDefault $1 $3 }
 190
 191 core_arg        :: { UfArg RdrName }
 192                 : any_var_name                                  { UfVarArg $1 }
 193                 | data_name                                     { UfVarArg $1 }
 194                 | core_lit                                      { UfLitArg $1 }
 195
 196 core_args       :: { [UfArg RdrName] }
 197                 :                                               { [] }
 198                 | core_arg core_args                            { $1 : $2 }
 199
 200 data_args       :: { [UfArg RdrName] }
 201                 :                                               { [] }
 202                 | ATSIGN atype data_args                        { UfTyArg $2 : $3 }
 203                 | core_arg data_args                            { $1 : $2 }
 204
 205 core_lit        :: { Literal }
 206 core_lit        : INTEGER                       { MachInt $1 True }
 207                 | CHAR                          { MachChar $1 }
 208                 | STRING                        { MachStr $1 }
 209                 | STRING_LIT STRING             { NoRepStr $2 }
 210                 | DOUBLE                        { MachDouble (toRational $1) }
 211                 | FLOAT_LIT DOUBLE              { MachFloat (toRational $2) }
 212
 213                 | INTEGER_LIT INTEGER           { NoRepInteger  $2 (panic "NoRepInteger type")
 214                                                         -- The type checker will add the types
 215                                                 }
 216
 217                 | RATIONAL_LIT INTEGER INTEGER  { NoRepRational ($2 % $3)
 218                                                                 (panic "NoRepRational type")
 219                                                                         -- The type checker will add the type
 220                                                 }
 221
 222                 | ADDR_LIT INTEGER              { MachAddr $2 }
 223                 | LIT_LIT prim_rep STRING       { MachLitLit $3 (decodePrimRep $2) }
 224
 225 core_val_bndr   :: { UfBinder RdrName }
 226 core_val_bndr   : var_name DCOLON atype                         { UfValBinder $1 $3 }
 227
 228 core_val_bndrs  :: { [UfBinder RdrName] }
 229 core_val_bndrs  :                                               { [] }
 230                 | core_val_bndr core_val_bndrs                  { $1 : $2 }
 231
 232 core_tv_bndr    :: { UfBinder RdrName }
 233 core_tv_bndr    :  tv_name DCOLON akind                         { UfTyBinder $1 $3 }
 234                 |  tv_name                                      { UfTyBinder $1 mkTypeKind }
 235
 236 core_tv_bndrs   :: { [UfBinder RdrName] }
 237 core_tv_bndrs   :                                               { [] }
 238                 | core_tv_bndr core_tv_bndrs                    { $1 : $2 }
 239
 240 ccall_string    :: { FAST_STRING }
 241                 : STRING                                        { $1 }
 242                 | VARID                                         { $1 }
 243                 | CONID                                         { $1 }
 244
 245 prim_rep  :: { Char }
 246           : VARID                                               { head (_UNPK_ $1) }
 247           | CONID                                               { head (_UNPK_ $1)
 248
 249 ---variable names-----------------------------------------------------
 250                                                                      }
 251 var_occ         :: { OccName }
 252 var_occ         : VARID                 { VarOcc $1 }
 253                 | VARSYM                { VarOcc $1 }
 254                 | BANG                  { VarOcc SLIT("!") {-sigh, double-sigh-} }
 255
 256 data_name       :: { RdrName }
 257 data_name       :  QCONID               { varQual $1 }
 258                 |  QCONSYM              { varQual $1 }
 259                 |  CONID                { Unqual (VarOcc $1) }
 260                 |  CONSYM               { Unqual (VarOcc $1) }
 261
 262 qvar_name       :: { RdrName }
 263                 :  QVARID               { varQual $1 }
 264                 |  QVARSYM              { varQual $1 }
 265
 266 var_name        :: { RdrName }
 267 var_name        :  var_occ              { Unqual $1 }
 268
 269 any_var_name    :: {RdrName}
 270 any_var_name    :  var_name             { $1 }
 271                 |  qvar_name            { $1 }
 272
 273 var_names       :: { [RdrName] }
 274 var_names       :                       { [] }
 275                 | var_name var_names    { $1 : $2
 276
 277 --productions-for-types--------------------------------
 278                                              }
 279 forall          : OBRACK tv_bndrs CBRACK                { $2 }
 280
 281 context         :: { RdrNameContext }
 282 context         :                                       { [] }
 283                 | OCURLY context_list1 CCURLY           { $2 }
 284
 285 context_list1   :: { RdrNameContext }
 286 context_list1   : class                                 { [$1] }
 287                 | class COMMA context_list1             { $1 : $3 }
 288
 289 class           :: { (RdrName, RdrNameHsType) }
 290 class           :  tc_name atype                        { ($1, $2) }
 291
 292 type            :: { RdrNameHsType }
 293 type            : FORALL forall context DARROW type     { mkHsForAllTy $2 $3 $5 }
 294                 |  btype RARROW type                    { MonoFunTy $1 $3 }
 295                 |  btype                                { $1 }
 296
 297 types2          :: { [RdrNameHsType]                    {- Two or more -}  }
 298 types2          :  type COMMA type                      { [$1,$3] }
 299                 |  type COMMA types2                    { $1 : $3 }
 300
 301 btype           :: { RdrNameHsType }
 302 btype           :  atype                                { $1 }
 303                 |  btype atype                          { MonoTyApp $1 $2 }
 304
 305 atype           :: { RdrNameHsType }
 306 atype           :  tc_name                              { MonoTyVar $1 }
 307                 |  tv_name                              { MonoTyVar $1 }
 308                 |  OPAREN types2 CPAREN                 { MonoTupleTy dummyRdrTcName $2 }
 309                 |  OBRACK type CBRACK                   { MonoListTy  dummyRdrTcName $2 }
 310                 |  OCURLY tc_name atype CCURLY          { MonoDictTy $2 $3 }
 311                 |  OPAREN type CPAREN                   { $2 }
 312
 313 atypes          :: { [RdrNameHsType]    {-  Zero or more -} }
 314 atypes          :                                       { [] }
 315                 |  atype atypes                         { $1 : $2
 316 ---------------------------------------------------------------------
 317                                                         }
 318
 319 tv_bndr         :: { HsTyVar RdrName }
 320 tv_bndr         :  tv_name DCOLON akind { IfaceTyVar $1 $3 }
 321                 |  tv_name              { UserTyVar $1 }
 322
 323 tv_bndrs        :: { [HsTyVar RdrName] }
 324                 :                       { [] }
 325                 | tv_bndr tv_bndrs      { $1 : $2 }
 326
 327 kind            :: { Kind }
 328                 : akind                 { $1 }
 329                 | akind RARROW kind     { mkArrowKind $1 $3 }
 330
 331 akind           :: { Kind }
 332                 : VARSYM                { mkTypeKind {- ToDo: check that it's "*" -} }
 333                 | OPAREN kind CPAREN    { $2 }
 334
 335 tv_name         :: { RdrName }
 336 tv_name         :  VARID                { Unqual (TvOcc $1) }
 337
 338 tv_names        :: { [RdrName] }
 339                 :                       { [] }
 340                 | tv_name tv_names      { $1 : $2 }
 341
 342 tc_name         :: { RdrName }
 343 tc_name         :  QCONID               { tcQual $1 }
 344                 |  CONID                { Unqual (TCOcc $1) }
 345                 |  CONSYM               { Unqual (TCOcc $1) }
 346                 |  OPAREN RARROW CPAREN { Unqual (TCOcc SLIT("->")) }