compiler/parser/ParserCore.y

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