root/compiler/parser/ParserCore.y

Revision fc8959acae02605c71b775c8d403e38b5cc6fecd, 12.2 KB (checked in by Simon Peyton Jones <simonpj@…>, 2 weeks ago)

Refactor LHsTyVarBndrs to fix Trac #6081

This is really a small change, but it touches a lot of files quite
significantly. The real goal is to put the implicitly-bound kind
variables of a data/class decl in the right place, namely on the
LHsTyVarBndrs type, which now looks like

data LHsTyVarBndrs name

= HsQTvs { hsq_kvs :: [Name]

, hsq_tvs
[LHsTyVarBndr name] }

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