2 module ParserCore ( parseCore ) where
14 import ParserCoreUtils
24 #include "../HsVersions.h"
32 '%module' { TKmodule }
34 '%newtype' { TKnewtype }
35 '%forall' { TKforall }
41 '%coerce' { TKcoerce }
43 '%external' { TKexternal }
61 INTEGER { TKinteger $$ }
62 RATIONAL { TKrational $$ }
63 STRING { TKstring $$ }
66 %monad { P } { thenP } { returnP }
67 %lexer { lexer } { TKEOF }
71 module :: { RdrNameHsModule }
72 : '%module' modid tdefs vdefgs
73 { HsModule (Just (mkHomeModule $2)) Nothing
74 [] ($3 ++ concat $4) Nothing noSrcLoc}
76 tdefs :: { [RdrNameHsDecl] }
78 | tdef ';' tdefs {$1:$3}
80 tdef :: { RdrNameHsDecl }
81 : '%data' q_tc_name tbinds '=' '{' cons1 '}'
82 { TyClD (mkTyData DataType ([], $2, $3) (DataCons $6) Nothing noSrcLoc) }
83 | '%newtype' q_tc_name tbinds trep
84 { TyClD (mkTyData NewType ([], $2, $3) ($4 $2) Nothing noSrcLoc) }
86 -- For a newtype we have to invent a fake data constructor name
87 -- It doesn't matter what it is, because it won't be used
88 trep :: { (RdrName -> DataConDetails (ConDecl RdrName)) }
89 : {- empty -} { (\ tc_name -> Unknown) }
90 | '=' ty { (\ tc_name -> let { dc_name = setRdrNameSpace tc_name dataName ;
91 con_info = PrefixCon [unbangedType $2] }
92 in DataCons [ConDecl dc_name [] [] con_info noSrcLoc]) }
94 tbind :: { HsTyVarBndr RdrName }
95 : name { IfaceTyVar $1 liftedTypeKind }
96 | '(' name '::' akind ')' { IfaceTyVar $2 $4 }
98 tbinds :: { [HsTyVarBndr RdrName] }
100 | tbind tbinds { $1:$2 }
102 vdefgs :: { [[RdrNameHsDecl]] }
104 | vdefg ';' vdefgs { ($1:$3) }
106 vdefg :: { [RdrNameHsDecl] }
107 : '%rec' '{' vdefs1 '}' { map CoreD $3 }
108 | vdef { [CoreD $1] }
110 let_bind :: { UfBinding RdrName }
111 : '%rec' '{' vdefs1 '}' { UfRec (map convBind $3) }
112 | vdef { let (b,r) = convBind $1
115 vdefs1 :: { [RdrNameCoreDecl] }
117 | vdef ';' vdefs1 { $1:$3 }
119 vdef :: { RdrNameCoreDecl }
120 : qname '::' ty '=' exp { CoreDecl $1 $3 $5 noSrcLoc }
121 -- NB: qname includes data constructors, because
122 -- we allow data-constructor wrappers at top level
125 vbind :: { (RdrName, RdrNameHsType) }
126 : '(' name '::' ty ')' { ($2,$4) }
128 vbinds :: { [(RdrName, RdrNameHsType)] }
130 | vbind vbinds { $1:$2 }
132 bind :: { UfBinder RdrName }
133 : '@' tbind { let (IfaceTyVar v k) = $2 in UfTyBinder v k }
134 | vbind { let (v,ty) = $1 in UfValBinder v ty }
136 binds1 :: { [UfBinder RdrName] }
138 | bind binds1 { $1:$2 }
140 attbinds :: { [RdrNameHsTyVar] }
142 | '@' tbind attbinds { $2:$3 }
145 : '*' { liftedTypeKind }
146 | '#' { unliftedTypeKind }
147 | '?' { openTypeKind }
148 | '(' kind ')' { $2 }
152 | akind '->' kind { mkArrowKind $1 $3 }
154 cons1 :: { [ConDecl RdrName] }
156 | con ';' cons1 { $1:$3 }
158 con :: { ConDecl RdrName }
159 : q_d_patt attbinds atys
160 { ConDecl $1 $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc}
162 atys :: { [ RdrNameHsType] }
166 aty :: { RdrNameHsType }
167 : name { HsTyVar $1 }
168 | q_tc_name { HsTyVar $1 }
172 bty :: { RdrNameHsType }
174 | bty aty { HsAppTy $1 $2 }
176 ty :: { RdrNameHsType }
178 | bty '->' ty { HsFunTy $1 $3 }
179 | '%forall' tbinds '.' ty { HsForAllTy (Just $2) [] $4 }
181 aexp :: { UfExpr RdrName }
186 fexp :: { UfExpr RdrName }
187 : fexp aexp { UfApp $1 $2 }
188 | fexp '@' aty { UfApp $1 (UfType $3) }
191 exp :: { UfExpr RdrName }
193 | '\\' binds1 '->' exp { foldr UfLam $4 $2 }
194 | '%let' let_bind '%in' exp { UfLet $2 $4 }
195 | '%case' aexp '%of' vbind
196 '{' alts1 '}' { UfCase $2 (fst $4) $6 }
197 | '%coerce' aty exp { UfNote (UfCoerce $2) $3 } -- what about the 'from' type?
200 --"SCC" -> UfNote (UfSCC "scc") $3
201 "InlineCall" -> UfNote UfInlineCall $3
202 "InlineMe" -> UfNote UfInlineMe $3
204 | '%external' STRING aty { UfFCall (ForeignCall.CCall
205 (CCallSpec (StaticTarget
207 CCallConv (PlaySafe False))) $3 }
208 alts1 :: { [UfAlt RdrName] }
210 | alt ';' alts1 { $1:$3 }
212 alt :: { UfAlt RdrName }
213 : q_d_patt attbinds vbinds '->' exp
214 { (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) }
216 { (UfLitAlt $1, [], $3) }
218 { (UfDefault, [], $3) }
221 : '(' INTEGER '::' aty ')' { convIntLit $2 $4 }
222 | '(' RATIONAL '::' aty ')' { convRatLit $2 $4 }
223 | '(' CHAR '::' aty ')' { MachChar (fromEnum $2) }
224 | '(' STRING '::' aty ')' { MachStr (mkFastString $2) }
227 : NAME { mkRdrUnqual (mkVarOccEncoded (mkFastString $1)) }
235 modid :: { ModuleName }
236 : CNAME { mkSysModuleNameFS (mkFastString $1) }
238 qname :: { RdrName } -- Includes data constructors
240 | mname '.' NAME { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) }
245 q_tc_name :: { RdrName }
247 { mkIfaceOrig tcName (mkFastString $1) (mkFastString $3) }
249 -- Data constructor in a pattern or data type declaration; use the dataName,
250 -- because that's what we expect in Core case patterns
251 q_d_patt :: { RdrName }
253 { mkIfaceOrig dataName (mkFastString $1) (mkFastString $3) }
255 -- Data constructor occurrence in an expression;
256 -- use the varName because that's the worker Id
257 q_d_occ :: { RdrName }
259 { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) }
263 convBind :: RdrNameCoreDecl -> (UfBinder RdrName, UfExpr RdrName)
264 convBind (CoreDecl n ty rhs _) = (UfValBinder n ty, rhs)
266 convIntLit :: Integer -> RdrNameHsType -> Literal
267 convIntLit i (HsTyVar n)
268 | n == intPrimRdrName = MachInt i
269 | n == wordPrimRdrName = MachWord i
270 | n == charPrimRdrName = MachChar (fromInteger i)
271 | n == addrPrimRdrName && i == 0 = MachNullAddr
273 = pprPanic "Unknown integer literal type" (ppr aty $$ ppr intPrimRdrName)
275 convRatLit :: Rational -> RdrNameHsType -> Literal
276 convRatLit r (HsTyVar n)
277 | n == floatPrimRdrName = MachFloat r
278 | n == doublePrimRdrName = MachDouble r
280 = pprPanic "Unknown rational literal type" (ppr aty $$ ppr intPrimRdrName)
283 wordPrimRdrName, intPrimRdrName, floatPrimRdrName, doublePrimRdrName, addrPrimRdrName :: RdrName
284 wordPrimRdrName = nameRdrName wordPrimTyConName
285 intPrimRdrName = nameRdrName intPrimTyConName
286 charPrimRdrName = nameRdrName charPrimTyConName
287 floatPrimRdrName = nameRdrName floatPrimTyConName
288 doublePrimRdrName = nameRdrName doublePrimTyConName
289 addrPrimRdrName = nameRdrName addrPrimTyConName
292 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l