compiler/parser/ParserCore.y

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