ParserCore.y 9.78 KB
Newer Older
sof's avatar
sof committed
1 2 3
{
module ParserCore ( parseCore ) where

4
import IfaceSyn
krc's avatar
krc committed
5
import ForeignCall
sof's avatar
sof committed
6 7 8 9
import RdrHsSyn
import HsSyn
import RdrName
import OccName
10
import Kind( Kind(..) )
11
import Name( nameOccName, nameModuleName )
sof's avatar
sof committed
12 13 14 15 16
import Module
import ParserCoreUtils
import LexCore
import Literal
import SrcLoc
17 18 19
import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon, 
		floatPrimTyCon, doublePrimTyCon, addrPrimTyCon )
import TyCon ( TyCon, tyConName )
20
import FastString
21
import Outputable
22
import Char
sof's avatar
sof committed
23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70

#include "../HsVersions.h"

}

%name parseCore
%tokentype { Token }

%token
 '%module'	{ TKmodule }
 '%data'	{ TKdata }
 '%newtype'	{ TKnewtype }
 '%forall'	{ TKforall }
 '%rec'		{ TKrec }
 '%let'		{ TKlet }
 '%in'		{ TKin }
 '%case'	{ TKcase }
 '%of'		{ TKof }
 '%coerce'	{ TKcoerce }
 '%note'	{ TKnote }
 '%external'	{ TKexternal }
 '%_'		{ TKwild }
 '('		{ TKoparen }
 ')'		{ TKcparen }
 '{'		{ TKobrace }
 '}'		{ TKcbrace }
 '#' 		{ TKhash}
 '='		{ TKeq }
 '::'		{ TKcoloncolon }
 '*'		{ TKstar }
 '->'		{ TKrarrow }
 '\\'		{ TKlambda}
 '@'		{ TKat }
 '.'		{ TKdot }
 '?'		{ TKquestion}
 ';'            { TKsemicolon }
 NAME		{ TKname $$ }
 CNAME 		{ TKcname $$ }
 INTEGER	{ TKinteger $$ }
 RATIONAL	{ TKrational $$ }
 STRING		{ TKstring $$ }
 CHAR		{ TKchar $$ }

%monad { P } { thenP } { returnP }
%lexer { lexer } { TKEOF }

%%

71 72 73 74 75 76 77 78 79
module	:: { HsExtCore RdrName }
         : '%module' modid tdefs vdefgs
		{ HsExtCore (mkHomeModule $2) $3 $4 }

modid	:: { ModuleName }
	: CNAME	                 { mkSysModuleNameFS (mkFastString $1) }

-------------------------------------------------------------
--     Type and newtype declarations are in HsSyn syntax
sof's avatar
sof committed
80

81
tdefs	:: { [TyClDecl RdrName] }
sof's avatar
sof committed
82 83 84
	: {- empty -}	{[]}
	| tdef ';' tdefs	{$1:$3}

85 86
tdef	:: { TyClDecl RdrName }
	: '%data' q_tc_name tv_bndrs '=' '{' cons1 '}'
87
                { mkTyData DataType (noLoc (noLoc [], noLoc (ifaceExtRdrName $2), map toHsTvBndr $3)) Nothing $6 Nothing }
88 89
	| '%newtype' q_tc_name tv_bndrs trep 
		{ let tc_rdr = ifaceExtRdrName $2 in
90
                  mkTyData NewType (noLoc (noLoc [], noLoc tc_rdr, map toHsTvBndr $3)) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
91 92 93

-- For a newtype we have to invent a fake data constructor name
-- It doesn't matter what it is, because it won't be used
94
trep    :: { OccName -> [LConDecl RdrName] }
95 96
        : {- empty -}   { (\ tc_occ -> []) }
        | '=' ty        { (\ tc_occ -> let { dc_name  = mkRdrUnqual (setOccNameSpace dataName tc_occ) ;
97
			                     con_info = PrefixCon [toHsType $2] }
98 99
			                in [noLoc $ ConDecl (noLoc dc_name) []
					   (noLoc []) con_info]) }
sof's avatar
sof committed
100

101
cons1	:: { [LConDecl RdrName] }
102 103
	: con		{ [$1] }
	| con ';' cons1	{ $1:$3 }
sof's avatar
sof committed
104

105
con	:: { LConDecl RdrName }
106
	: d_pat_occ attv_bndrs hs_atys 
107 108 109
		{ noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) $2 (noLoc []) (PrefixCon $3)}
        | d_pat_occ '::' ty
                { noLoc $ GadtDecl (noLoc (mkRdrUnqual $1)) (toHsType $3) } 
sof's avatar
sof committed
110

111
attv_bndrs :: { [LHsTyVarBndr RdrName] }
112 113
	: {- empty -} 	         { [] }
	| '@' tv_bndr attv_bndrs {  toHsTvBndr $2 : $3 }
sof's avatar
sof committed
114

115
hs_atys :: { [LHsType RdrName] }
116
         : atys               { map toHsType $1 }
sof's avatar
sof committed
117

118

119 120 121
---------------------------------------
--                 Types
---------------------------------------
sof's avatar
sof committed
122

123 124 125
atys	:: { [IfaceType] }
	: {- empty -}   { [] }
	| aty atys      { $1:$2 }
sof's avatar
sof committed
126

127 128 129 130
aty	:: { IfaceType }
	: tv_occ    { IfaceTyVar $1 }
	| q_tc_name  { IfaceTyConApp (IfaceTc $1) [] }
	| '(' ty ')' { $2 }
sof's avatar
sof committed
131

132 133 134
bty	:: { IfaceType }
	: tv_occ atys    { foldl IfaceAppTy (IfaceTyVar $1) $2 }
        | q_tc_name atys  { IfaceTyConApp (IfaceTc $1) $2 }
sof's avatar
sof committed
135

136 137 138 139
ty	:: { IfaceType }
	: bty	                     { $1 }
	| bty '->' ty                { IfaceFunTy $1 $3 }
	| '%forall' tv_bndrs '.' ty  { foldr IfaceForAllTy $4 $2 }
sof's avatar
sof committed
140

141 142
----------------------------------------------
--        Bindings are in Iface syntax
sof's avatar
sof committed
143

144 145 146
vdefgs	:: { [IfaceBinding] }
	: {- empty -}	        { [] }
	| let_bind ';' vdefgs	{ $1 : $3 }
sof's avatar
sof committed
147

148 149 150 151
let_bind :: { IfaceBinding }
	: '%rec' '{' vdefs1 '}' { IfaceRec $3 }
	|  vdef                 { let (b,r) = $1
				  in IfaceNonRec b r }
sof's avatar
sof committed
152

153 154 155
vdefs1	:: { [(IfaceIdBndr, IfaceExpr)] }
	: vdef		        { [$1] }
	| vdef ';' vdefs1       { $1:$3 }
sof's avatar
sof committed
156

157 158 159 160 161 162 163
vdef	:: { (IfaceIdBndr, IfaceExpr) }
	: qd_occ '::' ty '=' exp { (($1, $3), $5) }
  -- NB: qd_occ includes data constructors, because
  --     we allow data-constructor wrappers at top level
  -- But we discard the module name, because it must be the
  -- same as the module being compiled, and Iface syntax only
  -- has OccNames in binding positions
sof's avatar
sof committed
164

165 166 167
qd_occ :: { OccName }
        : var_occ { $1 }
        | d_occ   { $1 }
sof's avatar
sof committed
168

169 170 171 172 173
---------------------------------------
--  Binders
bndr	:: { IfaceBndr }
        : '@' tv_bndr 	{ IfaceTvBndr $2 }
	| id_bndr	{ IfaceIdBndr $1 }
sof's avatar
sof committed
174

175 176 177
bndrs 	:: { [IfaceBndr] }
	: bndr		{ [$1] }
	| bndr bndrs	{ $1:$2 }
sof's avatar
sof committed
178

179 180
id_bndr	:: { IfaceIdBndr }
	: '(' var_occ '::' ty ')'	{ ($2,$4) }
sof's avatar
sof committed
181

182 183 184 185 186
id_bndrs :: { [IfaceIdBndr] }
	: {-empty -}    	{ [] }
	| id_bndr id_bndrs	{ $1:$2 }

tv_bndr	:: { IfaceTvBndr }
187
	:  tv_occ                    { ($1, LiftedTypeKind) }
188 189 190 191 192 193 194
	|  '(' tv_occ '::' akind ')' { ($2, $4) }

tv_bndrs 	:: { [IfaceTvBndr] }
	: {- empty -}	{ [] }
	| tv_bndr tv_bndrs	{ $1:$2 }

akind	:: { IfaceKind }
195 196 197
	: '*' 		   { LiftedTypeKind   }	
	| '#'		   { UnliftedTypeKind }
	| '?'		   { OpenTypeKind     }
198
        | '(' kind ')'	   { $2 }
sof's avatar
sof committed
199

200 201
kind 	:: { IfaceKind }
	: akind 	   { $1 }
202
	| akind '->' kind  { FunKind $1 $3 }
sof's avatar
sof committed
203

204 205
-----------------------------------------
--             Expressions
sof's avatar
sof committed
206

207 208 209 210
aexp    :: { IfaceExpr }
	: var_occ	         { IfaceLcl $1 }
	| modid '.' qd_occ	 { IfaceExt (ExtPkg $1 $3) }
	| lit		{ IfaceLit $1 }
sof's avatar
sof committed
211 212
	| '(' exp ')' 	{ $2 }

213 214 215
fexp	:: { IfaceExpr }
	: fexp aexp	{ IfaceApp $1 $2 }
	| fexp '@' aty	{ IfaceApp $1 (IfaceType $3) }
sof's avatar
sof committed
216 217
	| aexp		{ $1 }

218 219 220 221
exp	:: { IfaceExpr }
	: fexp		              { $1 }
	| '\\' bndrs '->' exp 	      { foldr IfaceLam $4 $2 }
	| '%let' let_bind '%in' exp   { IfaceLet $2 $4 }
222 223 224
-- gaw 2004
	| '%case' '(' ty ')' aexp '%of' id_bndr
	  '{' alts1 '}'		      { IfaceCase $5 (fst $7) $3 $9 }
225
	| '%coerce' aty exp   	      { IfaceNote (IfaceCoerce $2) $3 }
sof's avatar
sof committed
226 227
	| '%note' STRING exp 	   
	    { case $2 of
228 229 230
	       --"SCC"      -> IfaceNote (IfaceSCC "scc") $3
	       "InlineCall" -> IfaceNote IfaceInlineCall $3
	       "InlineMe"   -> IfaceNote IfaceInlineMe $3
sof's avatar
sof committed
231
            }
232 233 234 235 236 237
        | '%external' STRING aty   { IfaceFCall (ForeignCall.CCall 
                                                    (CCallSpec (StaticTarget (mkFastString $2)) 
                                                               CCallConv (PlaySafe False))) 
                                                 $3 }

alts1	:: { [IfaceAlt] }
sof's avatar
sof committed
238 239 240
	: alt		{ [$1] }
	| alt ';' alts1	{ $1:$3 }

241 242 243 244 245 246
alt	:: { IfaceAlt }
	: modid '.' d_pat_occ bndrs '->' exp 
		{ (IfaceDataAlt $3, map ifaceBndrName $4, $6) } 
                       -- The external syntax currently includes the types of the
		       -- the args, but they aren't needed internally
                       -- Nor is the module qualifier
sof's avatar
sof committed
247
	| lit '->' exp
248
		{ (IfaceLitAlt $1, [], $3) }
sof's avatar
sof committed
249
	| '%_' '->' exp
250
		{ (IfaceDefault, [], $3) }
sof's avatar
sof committed
251 252

lit	:: { Literal }
253
	: '(' INTEGER '::' aty ')'	{ convIntLit $2 $4 }
254
	| '(' RATIONAL '::' aty ')'	{ convRatLit $2 $4 }
255
	| '(' CHAR '::' aty ')'		{ MachChar $2 }
256
	| '(' STRING '::' aty ')'	{ MachStr (mkFastString $2) }
sof's avatar
sof committed
257

258 259
tv_occ	:: { OccName }
	: NAME	{ mkSysOcc tvName $1 }
sof's avatar
sof committed
260

261 262
var_occ	:: { OccName }
	: NAME	{ mkSysOcc varName $1 }
263

sof's avatar
sof committed
264

265
-- Type constructor
266 267
q_tc_name	:: { IfaceExtName }
        : modid '.' CNAME	{ ExtPkg $1 (mkSysOcc tcName $3) }
268

269 270
-- Data constructor in a pattern or data type declaration; use the dataName, 
-- because that's what we expect in Core case patterns
271 272
d_pat_occ :: { OccName }
        : CNAME      { mkSysOcc dataName $1 }
sof's avatar
sof committed
273

274 275
-- Data constructor occurrence in an expression;
-- use the varName because that's the worker Id
276 277
d_occ :: { OccName }
       : CNAME { mkSysOcc varName $1 }
sof's avatar
sof committed
278 279

{
280

281 282
ifaceBndrName (IfaceIdBndr (n,_)) = n
ifaceBndrName (IfaceTvBndr (n,_)) = n
283

284 285 286 287
convIntLit :: Integer -> IfaceType -> Literal
convIntLit i (IfaceTyConApp tc [])
  | tc `eqTc` intPrimTyCon  = MachInt  i  
  | tc `eqTc` wordPrimTyCon = MachWord i
288
  | tc `eqTc` charPrimTyCon = MachChar (chr (fromInteger i))
289 290 291
  | tc `eqTc` addrPrimTyCon && i == 0 = MachNullAddr
convIntLit i aty
  = pprPanic "Unknown integer literal type" (ppr aty)
292

293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310
convRatLit :: Rational -> IfaceType -> Literal
convRatLit r (IfaceTyConApp tc [])
  | tc `eqTc` floatPrimTyCon  = MachFloat  r
  | tc `eqTc` doublePrimTyCon = MachDouble r
convRatLit i aty
  = pprPanic "Unknown rational literal type" (ppr aty)

eqTc :: IfaceTyCon -> TyCon -> Bool   -- Ugh!
eqTc (IfaceTc (ExtPkg mod occ)) tycon
  = mod == nameModuleName nm && occ == nameOccName nm
  where
    nm = tyConName tycon

-- Tiresomely, we have to generate both HsTypes (in type/class decls) 
-- and IfaceTypes (in Core expressions).  So we parse them as IfaceTypes,
-- and convert to HsTypes here.  But the IfaceTypes we can see here
-- are very limited (see the productions for 'ty', so the translation
-- isn't hard
311 312 313 314 315
toHsType :: IfaceType -> LHsType RdrName
toHsType (IfaceTyVar v)        		 = noLoc $ HsTyVar (mkRdrUnqual v)
toHsType (IfaceAppTy t1 t2)    		 = noLoc $ HsAppTy (toHsType t1) (toHsType t2)
toHsType (IfaceFunTy t1 t2)    		 = noLoc $ HsFunTy (toHsType t1) (toHsType t2)
toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts) 
316 317
toHsType (IfaceForAllTy tv t)            = add_forall (toHsTvBndr tv) (toHsType t)

318
toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
319
toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual tv) k
320 321 322 323 324

ifaceExtRdrName :: IfaceExtName -> RdrName
ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ
ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other)

325 326 327 328
add_forall tv (L _ (HsForAllTy exp tvs cxt t))
  = noLoc $ HsForAllTy exp (tv:tvs) cxt t
add_forall tv t
  = noLoc $ HsForAllTy Explicit [tv] (noLoc []) t
329
  
sof's avatar
sof committed
330 331 332
happyError :: P a 
happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
}
333