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