← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to compiler/parser/ParserCore.y.source

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

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