ghc/compiler/parser/ParserCore.y

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