2 module ParserCore ( parseCore ) where
12 import ParserCoreUtils
22 #include "../HsVersions.h"
30 '%module' { TKmodule }
32 '%newtype' { TKnewtype }
33 '%forall' { TKforall }
39 '%coerce' { TKcoerce }
41 '%external' { TKexternal }
59 INTEGER { TKinteger $$ }
60 RATIONAL { TKrational $$ }
61 STRING { TKstring $$ }
64 %monad { P } { thenP } { returnP }
65 %lexer { lexer } { TKEOF }
69 module :: { RdrNameHsModule }
70 : '%module' modid tdefs vdefgs
71 { HsModule (mkHomeModule $2) Nothing Nothing
72 [] ($3 ++ concat $4) Nothing noSrcLoc}
74 tdefs :: { [RdrNameHsDecl] }
76 | tdef ';' tdefs {$1:$3}
78 tdef :: { RdrNameHsDecl }
79 : '%data' q_tc_name tbinds '=' '{' cons1 '}'
80 { TyClD (mkTyData DataType ([], $2, $3) (DataCons $6) Nothing noSrcLoc) }
81 | '%newtype' q_tc_name tbinds trep
82 { TyClD (mkTyData NewType ([], $2, $3) ($4 $2) Nothing noSrcLoc) }
84 -- For a newtype we have to invent a fake data constructor name
85 -- It doesn't matter what it is, because it won't be used
86 trep :: { (RdrName -> DataConDetails (ConDecl RdrName)) }
87 : {- empty -} { (\ tc_name -> Unknown) }
88 | '=' ty { (\ tc_name -> let { dc_name = setRdrNameSpace tc_name dataName ;
89 con_info = PrefixCon [unbangedType $2] }
90 in DataCons [ConDecl dc_name [] [] con_info noSrcLoc]) }
92 tbind :: { HsTyVarBndr RdrName }
93 : name { IfaceTyVar $1 liftedTypeKind }
94 | '(' name '::' akind ')' { IfaceTyVar $2 $4 }
96 tbinds :: { [HsTyVarBndr RdrName] }
98 | tbind tbinds { $1:$2 }
100 vdefgs :: { [[RdrNameHsDecl]] }
102 | vdefg ';' vdefgs { ($1:$3) }
104 vdefg :: { [RdrNameHsDecl] }
105 : '%rec' '{' vdefs1 '}' { map CoreD $3 }
106 | vdef { [CoreD $1] }
108 let_bind :: { UfBinding RdrName }
109 : '%rec' '{' vdefs1 '}' { UfRec (map convBind $3) }
110 | vdef { let (b,r) = convBind $1
113 vdefs1 :: { [RdrNameCoreDecl] }
115 | vdef ';' vdefs1 { $1:$3 }
117 vdef :: { RdrNameCoreDecl }
118 : qname '::' ty '=' exp { CoreDecl $1 $3 $5 noSrcLoc }
119 -- NB: qname includes data constructors, because
120 -- we allow data-constructor wrappers at top level
123 vbind :: { (RdrName, RdrNameHsType) }
124 : '(' name '::' ty ')' { ($2,$4) }
126 vbinds :: { [(RdrName, RdrNameHsType)] }
128 | vbind vbinds { $1:$2 }
130 bind :: { UfBinder RdrName }
131 : '@' tbind { let (IfaceTyVar v k) = $2 in UfTyBinder v k }
132 | vbind { let (v,ty) = $1 in UfValBinder v ty }
134 binds1 :: { [UfBinder RdrName] }
136 | bind binds1 { $1:$2 }
138 attbinds :: { [RdrNameHsTyVar] }
140 | '@' tbind attbinds { $2:$3 }
143 : '*' { liftedTypeKind }
144 | '#' { unliftedTypeKind }
145 | '?' { openTypeKind }
146 | '(' kind ')' { $2 }
150 | akind '->' kind { mkArrowKind $1 $3 }
152 cons1 :: { [ConDecl RdrName] }
154 | con ';' cons1 { $1:$3 }
156 con :: { ConDecl RdrName }
157 : q_d_patt attbinds atys
158 { ConDecl $1 $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc}
160 atys :: { [ RdrNameHsType] }
164 aty :: { RdrNameHsType }
165 : name { HsTyVar $1 }
166 | q_tc_name { HsTyVar $1 }
170 bty :: { RdrNameHsType }
172 | bty aty { HsAppTy $1 $2 }
174 ty :: { RdrNameHsType }
176 | bty '->' ty { HsFunTy $1 $3 }
177 | '%forall' tbinds '.' ty { HsForAllTy (Just $2) [] $4 }
179 aexp :: { UfExpr RdrName }
184 fexp :: { UfExpr RdrName }
185 : fexp aexp { UfApp $1 $2 }
186 | fexp '@' aty { UfApp $1 (UfType $3) }
189 exp :: { UfExpr RdrName }
191 | '\\' binds1 '->' exp { foldr UfLam $4 $2 }
192 | '%let' let_bind '%in' exp { UfLet $2 $4 }
193 | '%case' aexp '%of' vbind
194 '{' alts1 '}' { UfCase $2 (fst $4) $6 }
195 | '%coerce' aty exp { UfNote (UfCoerce $2) $3 } -- what about the 'from' type?
198 --"SCC" -> UfNote (UfSCC "scc") $3
199 "InlineCall" -> UfNote UfInlineCall $3
200 "InlineMe" -> UfNote UfInlineMe $3
202 -- | '%external' STRING aty { External $2 $3 }
204 alts1 :: { [UfAlt RdrName] }
206 | alt ';' alts1 { $1:$3 }
208 alt :: { UfAlt RdrName }
209 : q_d_patt attbinds vbinds '->' exp
210 { (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) }
212 { (UfLitAlt $1, [], $3) }
214 { (UfDefault, [], $3) }
217 : '(' INTEGER '::' aty ')' { convIntLit $2 $4 }
218 | '(' RATIONAL '::' aty ')' { convRatLit $2 $4 }
219 | '(' CHAR '::' aty ')' { MachChar (fromEnum $2) }
220 | '(' STRING '::' aty ')' { MachStr (mkFastString $2) }
223 : NAME { mkRdrUnqual (mkVarOccEncoded (mkFastString $1)) }
231 modid :: { ModuleName }
232 : CNAME { mkSysModuleNameFS (mkFastString $1) }
234 qname :: { RdrName } -- Includes data constructors
236 | mname '.' NAME { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) }
241 q_tc_name :: { RdrName }
243 { mkIfaceOrig tcName (mkFastString $1) (mkFastString $3) }
245 -- Data constructor in a pattern or data type declaration; use the dataName,
246 -- because that's what we expect in Core case patterns
247 q_d_patt :: { RdrName }
249 { mkIfaceOrig dataName (mkFastString $1) (mkFastString $3) }
251 -- Data constructor occurrence in an expression;
252 -- use the varName because that's the worker Id
253 q_d_occ :: { RdrName }
255 { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) }
259 convBind :: RdrNameCoreDecl -> (UfBinder RdrName, UfExpr RdrName)
260 convBind (CoreDecl n ty rhs _) = (UfValBinder n ty, rhs)
262 convIntLit :: Integer -> RdrNameHsType -> Literal
263 convIntLit i (HsTyVar n)
264 | n == intPrimRdrName = MachInt i
265 | n == wordPrimRdrName = MachWord i
267 = pprPanic "Unknown integer literal type" (ppr aty $$ ppr intPrimRdrName)
269 convRatLit :: Rational -> RdrNameHsType -> Literal
270 convRatLit r (HsTyVar n)
271 | n == floatPrimRdrName = MachFloat r
272 | n == doublePrimRdrName = MachDouble r
274 = pprPanic "Unknown rational literal type" (ppr aty $$ ppr intPrimRdrName)
277 wordPrimRdrName, intPrimRdrName, floatPrimRdrName, doublePrimRdrName :: RdrName
278 wordPrimRdrName = nameRdrName wordPrimTyConName
279 intPrimRdrName = nameRdrName intPrimTyConName
280 floatPrimRdrName = nameRdrName floatPrimTyConName
281 doublePrimRdrName = nameRdrName doublePrimTyConName
284 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l