compiler/parser/ParserCore.y

   1 {
   2 {-# OPTIONS -w #-}
   3 -- The above warning supression flag is a temporary kludge.
   4 -- While working on this module you are encouraged to remove it and fix
   5 -- any warnings in the module. See
   6 --     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
   7 -- for details
   8
   9 module ParserCore ( parseCore ) where
  10
  11 import IfaceSyn
  12 import ForeignCall
  13 import RdrHsSyn
  14 import HsSyn
  15 import RdrName
  16 import OccName
  17 import Type ( Kind,
  18               liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
  19               argTypeKindTyCon, ubxTupleKindTyCon, mkArrowKind, mkTyConApp
  20             )
  21 import Name( Name, nameOccName, nameModule, mkExternalName )
  22 import Module
  23 import PackageConfig    ( mainPackageId, stringToPackageId )
  24 import ParserCoreUtils
  25 import LexCore
  26 import Literal
  27 import SrcLoc
  28 import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon,
  29                 floatPrimTyCon, doublePrimTyCon, addrPrimTyCon )
  30 import TyCon ( TyCon, tyConName )
  31 import FastString
  32 import Outputable
  33 import Char
  34 import Unique
  35
  36 #include "../HsVersions.h"
  37
  38 }
  39
  40 %name parseCore
  41 %tokentype { Token }
  42
  43 %token
  44  '%module'      { TKmodule }
  45  '%data'        { TKdata }
  46  '%newtype'     { TKnewtype }
  47  '%forall'      { TKforall }
  48  '%rec'         { TKrec }
  49  '%let'         { TKlet }
  50  '%in'          { TKin }
  51  '%case'        { TKcase }
  52  '%of'          { TKof }
  53  '%cast'        { TKcast }
  54  '%note'        { TKnote }
  55  '%external'    { TKexternal }
  56  '%local'       { TKlocal }
  57  '%_'           { TKwild }
  58  '('            { TKoparen }
  59  ')'            { TKcparen }
  60  '{'            { TKobrace }
  61  '}'            { TKcbrace }
  62  '#'            { TKhash}
  63  '='            { TKeq }
  64  ':'            { TKcolon }
  65  '::'           { TKcoloncolon }
  66  ':=:'          { TKcoloneqcolon }
  67  '*'            { TKstar }
  68  '->'           { TKrarrow }
  69  '\\'           { TKlambda}
  70  '@'            { TKat }
  71  '.'            { TKdot }
  72  '?'            { TKquestion}
  73  ';'            { TKsemicolon }
  74  NAME           { TKname $$ }
  75  CNAME          { TKcname $$ }
  76  INTEGER        { TKinteger $$ }
  77  RATIONAL       { TKrational $$ }
  78  STRING         { TKstring $$ }
  79  CHAR           { TKchar $$ }
  80
  81 %monad { P } { thenP } { returnP }
  82 %lexer { lexer } { TKEOF }
  83
  84 %%
  85
  86 module  :: { HsExtCore RdrName }
  87         -- : '%module' modid tdefs vdefgs       { HsExtCore $2 $3 $4 }
  88         : '%module' modid tdefs vdefgs  { HsExtCore $2 [] [] }
  89
  90
  91 -------------------------------------------------------------
  92 --     Names: the trickiest bit in here
  93
  94 -- A name of the form A.B.C could be:
  95 --   module A.B.C
  96 --   dcon C in module A.B
  97 --   tcon C in module A.B
  98 modid   :: { Module }
  99         : NAME ':' mparts               { undefined }
 100
 101 q_dc_name :: { Name }
 102           : NAME ':' mparts             { undefined }
 103
 104 q_tc_name :: { Name }
 105           : NAME ':' mparts             { undefined }
 106
 107 q_var_occ :: { Name }
 108           : NAME ':' vparts             { undefined }
 109
 110 mparts  :: { [String] }
 111         : CNAME                         { [$1] }
 112         | CNAME '.' mparts              { $1:$3 }
 113
 114 vparts  :: { [String] }
 115         : var_occ                       { [$1] }
 116         | CNAME '.' vparts              { $1:$3 }
 117
 118 -------------------------------------------------------------
 119 --     Type and newtype declarations are in HsSyn syntax
 120
 121 tdefs   :: { [TyClDecl RdrName] }
 122         : {- empty -}   {[]}
 123         | tdef tdefs    {$1:$2}
 124
 125 tdef    :: { TyClDecl RdrName }
 126         : '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';'
 127                 { mkTyData DataType ( noLoc []
 128                                     , noLoc (ifaceExtRdrName $2)
 129                                     , map toHsTvBndr $3
 130                                     , Nothing
 131                                     ) Nothing $6 Nothing }
 132         | '%newtype' q_tc_name tv_bndrs trep ';'
 133                 { let tc_rdr = ifaceExtRdrName $2 in
 134                   mkTyData NewType ( noLoc []
 135                                    , noLoc tc_rdr
 136                                    , map toHsTvBndr $3
 137                                    , Nothing
 138                                    ) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
 139
 140 -- For a newtype we have to invent a fake data constructor name
 141 -- It doesn't matter what it is, because it won't be used
 142 trep    :: { OccName -> [LConDecl RdrName] }
 143         : {- empty -}   { (\ tc_occ -> []) }
 144         | '=' ty        { (\ tc_occ -> let { dc_name  = mkRdrUnqual (setOccNameSpace dataName tc_occ) ;
 145                                              con_info = PrefixCon [toHsType $2] }
 146                                         in [noLoc $ ConDecl (noLoc dc_name) Explicit []
 147                                            (noLoc []) con_info ResTyH98 Nothing]) }
 148
 149 cons    :: { [LConDecl RdrName] }
 150         : {- empty -}   { [] } -- 20060420 Empty data types allowed. jds
 151         | con           { [$1] }
 152         | con ';' cons  { $1:$3 }
 153
 154 con     :: { LConDecl RdrName }
 155         : d_pat_occ attv_bndrs hs_atys
 156                 { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit $2 (noLoc []) (PrefixCon $3) ResTyH98 Nothing }
 157         | d_pat_occ '::' ty
 158                 -- XXX - audreyt - $3 needs to be split into argument and return types!
 159                 -- also not sure whether the [] below (quantified vars) appears.
 160                 -- also the "PrefixCon []" is wrong.
 161                 -- also we want to munge $3 somehow.
 162                 -- extractWhatEver to unpack ty into the parts to ConDecl
 163                 -- XXX - define it somewhere in RdrHsSyn
 164                 { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit [] (noLoc []) (PrefixCon []) (undefined $3) Nothing }
 165
 166 attv_bndrs :: { [LHsTyVarBndr RdrName] }
 167         : {- empty -}            { [] }
 168         | '@' tv_bndr attv_bndrs {  toHsTvBndr $2 : $3 }
 169
 170 hs_atys :: { [LHsType RdrName] }
 171          : atys               { map toHsType $1 }
 172
 173
 174 ---------------------------------------
 175 --                 Types
 176 ---------------------------------------
 177
 178 atys    :: { [IfaceType] }
 179         : {- empty -}   { [] }
 180         | aty atys      { $1:$2 }
 181
 182 aty     :: { IfaceType }
 183         : fs_var_occ { IfaceTyVar $1 }
 184         | q_tc_name  { IfaceTyConApp (IfaceTc $1) [] }
 185         | '(' ty ')' { $2 }
 186
 187 bty     :: { IfaceType }
 188         : fs_var_occ atys { foldl IfaceAppTy (IfaceTyVar $1) $2 }
 189         | q_var_occ atys  { undefined }
 190         | q_tc_name atys  { IfaceTyConApp (IfaceTc $1) $2 }
 191         | '(' ty ')' { $2 }
 192
 193 ty      :: { IfaceType }
 194         : bty                        { $1 }
 195         | bty '->' ty                { IfaceFunTy $1 $3 }
 196         | '%forall' tv_bndrs '.' ty  { foldr IfaceForAllTy $4 $2 }
 197
 198 ----------------------------------------------
 199 --        Bindings are in Iface syntax
 200
 201 vdefgs  :: { [IfaceBinding] }
 202         : {- empty -}           { [] }
 203         | let_bind ';' vdefgs   { $1 : $3 }
 204
 205 let_bind :: { IfaceBinding }
 206         : '%rec' '{' vdefs1 '}' { IfaceRec $3 } -- Can be empty. Do we care?
 207         |  vdef                 { let (b,r) = $1
 208                                   in IfaceNonRec b r }
 209
 210 vdefs1  :: { [(IfaceLetBndr, IfaceExpr)] }
 211         : vdef                  { [$1] }
 212         | vdef ';' vdefs1       { $1:$3 }
 213
 214 vdef    :: { (IfaceLetBndr, IfaceExpr) }
 215         : fs_var_occ '::' ty '=' exp { (IfLetBndr $1 $3 NoInfo, $5) }
 216         | '%local' vdef              { $2 }
 217
 218   -- NB: qd_occ includes data constructors, because
 219   --     we allow data-constructor wrappers at top level
 220   -- But we discard the module name, because it must be the
 221   -- same as the module being compiled, and Iface syntax only
 222   -- has OccNames in binding positions. Ah, but it has Names now!
 223
 224 ---------------------------------------
 225 --  Binders
 226 bndr    :: { IfaceBndr }
 227         : '@' tv_bndr   { IfaceTvBndr $2 }
 228         | id_bndr       { IfaceIdBndr $1 }
 229
 230 bndrs   :: { [IfaceBndr] }
 231         : bndr          { [$1] }
 232         | bndr bndrs    { $1:$2 }
 233
 234 id_bndr :: { IfaceIdBndr }
 235         : '(' fs_var_occ '::' ty ')'    { ($2,$4) }
 236
 237 tv_bndr :: { IfaceTvBndr }
 238         :  fs_var_occ                    { ($1, ifaceLiftedTypeKind) }
 239         |  '(' fs_var_occ '::' akind ')' { ($2, $4) }
 240
 241 tv_bndrs        :: { [IfaceTvBndr] }
 242         : {- empty -}   { [] }
 243         | tv_bndr tv_bndrs      { $1:$2 }
 244
 245 akind   :: { IfaceKind }
 246         : '*'              { ifaceLiftedTypeKind }
 247         | '#'              { ifaceUnliftedTypeKind }
 248         | '?'              { ifaceOpenTypeKind }
 249         | '(' kind ')'     { $2 }
 250
 251 kind    :: { IfaceKind }
 252         : akind            { $1 }
 253         | akind '->' kind  { ifaceArrow $1 $3 }
 254         | ty ':=:' ty      { ifaceEq $1 $3 }
 255
 256 -----------------------------------------
 257 --             Expressions
 258
 259 aexp    :: { IfaceExpr }
 260         : fs_var_occ    { IfaceLcl $1 }
 261         | q_var_occ     { IfaceExt $1 }
 262         | q_dc_name     { IfaceExt $1 }
 263         | lit           { IfaceLit $1 }
 264         | '(' exp ')'   { $2 }
 265
 266 fexp    :: { IfaceExpr }
 267         : fexp aexp     { IfaceApp $1 $2 }
 268         | fexp '@' aty  { IfaceApp $1 (IfaceType $3) }
 269         | aexp          { $1 }
 270
 271 exp     :: { IfaceExpr }
 272         : fexp                        { $1 }
 273         | '\\' bndrs '->' exp         { foldr IfaceLam $4 $2 }
 274         | '%let' let_bind '%in' exp   { IfaceLet $2 $4 }
 275 -- gaw 2004
 276         | '%case' '(' ty ')' aexp '%of' id_bndr
 277           '{' alts1 '}'               { IfaceCase $5 (fst $7) $3 $9 }
 278         | '%cast' aexp aty { IfaceCast $2 $3 }
 279         | '%note' STRING exp
 280             { case $2 of
 281                --"SCC"      -> IfaceNote (IfaceSCC "scc") $3
 282                "InlineMe"   -> IfaceNote IfaceInlineMe $3
 283             }
 284         | '%external' STRING aty   { IfaceFCall (ForeignCall.CCall
 285                                                     (CCallSpec (StaticTarget (mkFastString $2))
 286                                                                CCallConv (PlaySafe False)))
 287                                                  $3 }
 288
 289 alts1   :: { [IfaceAlt] }
 290         : alt           { [$1] }
 291         | alt ';' alts1 { $1:$3 }
 292
 293 alt     :: { IfaceAlt }
 294         : q_dc_name bndrs '->' exp
 295                 { (IfaceDataAlt $1, map ifaceBndrName $2, $4) }
 296                        -- The external syntax currently includes the types of the
 297                        -- the args, but they aren't needed internally
 298                        -- Nor is the module qualifier
 299         | q_dc_name '->' exp
 300                 { (IfaceDataAlt $1, [], $3) }
 301         | lit '->' exp
 302                 { (IfaceLitAlt $1, [], $3) }
 303         | '%_' '->' exp
 304                 { (IfaceDefault, [], $3) }
 305
 306 lit     :: { Literal }
 307         : '(' INTEGER '::' aty ')'      { convIntLit $2 $4 }
 308         | '(' RATIONAL '::' aty ')'     { convRatLit $2 $4 }
 309         | '(' CHAR '::' aty ')'         { MachChar $2 }
 310         | '(' STRING '::' aty ')'       { MachStr (mkFastString $2) }
 311
 312 fs_var_occ      :: { FastString }
 313                 : NAME  { mkFastString $1 }
 314
 315 var_occ :: { String }
 316         : NAME  { $1 }
 317
 318
 319 -- Data constructor in a pattern or data type declaration; use the dataName,
 320 -- because that's what we expect in Core case patterns
 321 d_pat_occ :: { OccName }
 322         : CNAME      { mkOccName dataName $1 }
 323
 324 {
 325
 326 ifaceKind kc = IfaceTyConApp kc []
 327
 328 ifaceBndrName (IfaceIdBndr (n,_)) = n
 329 ifaceBndrName (IfaceTvBndr (n,_)) = n
 330
 331 convIntLit :: Integer -> IfaceType -> Literal
 332 convIntLit i (IfaceTyConApp tc [])
 333   | tc `eqTc` intPrimTyCon  = MachInt  i
 334   | tc `eqTc` wordPrimTyCon = MachWord i
 335   | tc `eqTc` charPrimTyCon = MachChar (chr (fromInteger i))
 336   | tc `eqTc` addrPrimTyCon && i == 0 = MachNullAddr
 337 convIntLit i aty
 338   = pprPanic "Unknown integer literal type" (ppr aty)
 339
 340 convRatLit :: Rational -> IfaceType -> Literal
 341 convRatLit r (IfaceTyConApp tc [])
 342   | tc `eqTc` floatPrimTyCon  = MachFloat  r
 343   | tc `eqTc` doublePrimTyCon = MachDouble r
 344 convRatLit i aty
 345   = pprPanic "Unknown rational literal type" (ppr aty)
 346
 347 eqTc :: IfaceTyCon -> TyCon -> Bool   -- Ugh!
 348 eqTc (IfaceTc name) tycon = name == tyConName tycon
 349
 350 -- Tiresomely, we have to generate both HsTypes (in type/class decls)
 351 -- and IfaceTypes (in Core expressions).  So we parse them as IfaceTypes,
 352 -- and convert to HsTypes here.  But the IfaceTypes we can see here
 353 -- are very limited (see the productions for 'ty', so the translation
 354 -- isn't hard
 355 toHsType :: IfaceType -> LHsType RdrName
 356 toHsType (IfaceTyVar v)                  = noLoc $ HsTyVar (mkRdrUnqual (mkTyVarOcc v))
 357 toHsType (IfaceAppTy t1 t2)              = noLoc $ HsAppTy (toHsType t1) (toHsType t2)
 358 toHsType (IfaceFunTy t1 t2)              = noLoc $ HsFunTy (toHsType t1) (toHsType t2)
 359 toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts)
 360 toHsType (IfaceForAllTy tv t)            = add_forall (toHsTvBndr tv) (toHsType t)
 361
 362 -- We also need to convert IfaceKinds to Kinds (now that they are different).
 363 -- Only a limited form of kind will be encountered... hopefully
 364 toKind :: IfaceKind -> Kind
 365 toKind (IfaceFunTy ifK1 ifK2)  = mkArrowKind (toKind ifK1) (toKind ifK2)
 366 toKind (IfaceTyConApp ifKc []) = mkTyConApp (toKindTc ifKc) []
 367 toKind other                   = pprPanic "toKind" (ppr other)
 368
 369 toKindTc :: IfaceTyCon -> TyCon
 370 toKindTc IfaceLiftedTypeKindTc   = liftedTypeKindTyCon
 371 toKindTc IfaceOpenTypeKindTc     = openTypeKindTyCon
 372 toKindTc IfaceUnliftedTypeKindTc = unliftedTypeKindTyCon
 373 toKindTc IfaceUbxTupleKindTc     = ubxTupleKindTyCon
 374 toKindTc IfaceArgTypeKindTc      = argTypeKindTyCon
 375 toKindTc other                   = pprPanic "toKindTc" (ppr other)
 376
 377 ifaceTcType ifTc = IfaceTyConApp ifTc []
 378
 379 ifaceLiftedTypeKind   = ifaceTcType IfaceLiftedTypeKindTc
 380 ifaceOpenTypeKind     = ifaceTcType IfaceOpenTypeKindTc
 381 ifaceUnliftedTypeKind = ifaceTcType IfaceUnliftedTypeKindTc
 382
 383 ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
 384
 385 ifaceEq ifT1 ifT2 = IfacePredTy (IfaceEqPred ifT1 ifT2)
 386
 387 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
 388 toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOcc tv)) (toKind k)
 389
 390 ifaceExtRdrName :: Name -> RdrName
 391 ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name)
 392 ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other)
 393
 394 add_forall tv (L _ (HsForAllTy exp tvs cxt t))
 395   = noLoc $ HsForAllTy exp (tv:tvs) cxt t
 396 add_forall tv t
 397   = noLoc $ HsForAllTy Explicit [tv] (noLoc []) t
 398
 399 happyError :: P a
 400 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
 401 }
 402