2 module ParserCore ( parseCore ) where
12 import ParserCoreUtils
20 #include "../HsVersions.h"
28 '%module' { TKmodule }
30 '%newtype' { TKnewtype }
31 '%forall' { TKforall }
37 '%coerce' { TKcoerce }
39 '%external' { TKexternal }
57 INTEGER { TKinteger $$ }
58 RATIONAL { TKrational $$ }
59 STRING { TKstring $$ }
62 %monad { P } { thenP } { returnP }
63 %lexer { lexer } { TKEOF }
67 module :: { RdrNameHsModule }
68 : '%module' modid tdefs vdefgs
69 { HsModule $2 Nothing Nothing [] ($3 ++ concat $4) Nothing noSrcLoc}
71 tdefs :: { [RdrNameHsDecl] }
73 | tdef ';' tdefs {$1:$3}
75 tdef :: { RdrNameHsDecl }
76 : '%data' q_tc_name tbinds '=' '{' cons1 '}'
77 { TyClD (TyData DataType [] $2 $3 (DataCons $6) Nothing [] noSrcLoc) }
78 | '%newtype' q_tc_name tbinds trep
79 { TyClD (TyData NewType [] $2 $3 ($4 $2 $3) Nothing [] noSrcLoc) }
81 trep :: { (RdrName -> [HsTyVarBndr RdrName] -> DataConDetails (ConDecl RdrName)) }
82 : {- empty -} { (\ x ts -> Unknown) }
83 | '=' ty { (\ x ts -> DataCons [ConDecl x x ts [] (VanillaCon [unbangedType $2]) noSrcLoc]) }
85 tbind :: { HsTyVarBndr RdrName }
86 : name { IfaceTyVar $1 liftedTypeKind }
87 | '(' name '::' akind ')' { IfaceTyVar $2 $4 }
89 tbinds :: { [HsTyVarBndr RdrName] }
91 | tbind tbinds { $1:$2 }
93 vdefgs :: { [[RdrNameHsDecl]] }
95 | vdefg ';' vdefgs { ($1:$3) }
97 vdefg :: { [RdrNameHsDecl] }
98 : '%rec' '{' vdefs1 '}' { $3 }
101 vdefs1 :: { [RdrNameHsDecl] }
103 | vdef ';' vdefs1 { $1:$3 }
105 vdef :: { RdrNameHsDecl }
106 : qname '::' ty '=' exp { TyClD (CoreDecl $1 $3 $5 noSrcLoc) }
109 vbind :: { (RdrName, RdrNameHsType) }
110 : '(' name '::' ty ')' { ($2,$4) }
112 vbinds :: { [(RdrName, RdrNameHsType)] }
114 | vbind vbinds { $1:$2 }
116 bind :: { UfBinder RdrName }
117 : '@' tbind { let (IfaceTyVar v k) = $2 in UfTyBinder v k }
118 | vbind { let (v,ty) = $1 in UfValBinder v ty }
120 binds1 :: { [UfBinder RdrName] }
122 | bind binds1 { $1:$2 }
124 attbinds :: { [RdrNameHsTyVar] }
126 | '@' tbind attbinds { $2:$3 }
129 : '*' { liftedTypeKind }
130 | '#' { unliftedTypeKind }
131 | '?' { openTypeKind }
132 | '(' kind ')' { $2 }
136 | akind '->' kind { mkArrowKind $1 $3 }
138 cons1 :: { [ConDecl RdrName] }
140 | con ';' cons1 { $1:$3 }
142 con :: { ConDecl RdrName }
143 : q_d_name attbinds atys
144 { ConDecl $1 $1 $2 [] (VanillaCon (map unbangedType $3)) noSrcLoc}
146 atys :: { [ RdrNameHsType] }
150 aty :: { RdrNameHsType }
151 : name { HsTyVar $1 }
152 | q_tc_name { HsTyVar $1 }
156 bty :: { RdrNameHsType }
158 | bty aty { HsAppTy $1 $2 }
160 ty :: { RdrNameHsType }
162 | bty '->' ty { HsFunTy $1 $3 }
163 | '%forall' tbinds '.' ty { HsForAllTy (Just $2) [] $4 }
165 aexp :: { UfExpr RdrName }
167 | q_d_name { UfVar $1 }
171 fexp :: { UfExpr RdrName }
172 : fexp aexp { UfApp $1 $2 }
173 | fexp '@' aty { UfApp $1 (UfType $3) }
176 exp :: { UfExpr RdrName }
178 | '\\' binds1 '->' exp { foldr UfLam $4 $2 }
179 | '%let' vdefg '%in' exp { UfLet (toUfBinder $2) $4 }
180 | '%case' aexp '%of' vbind
181 '{' alts1 '}' { UfCase $2 (fst $4) $6 }
182 | '%coerce' aty exp { UfNote (UfCoerce $2) $3 } -- what about the 'from' type?
185 --"SCC" -> UfNote (UfSCC "scc") $3
186 "InlineCall" -> UfNote UfInlineCall $3
187 "InlineMe" -> UfNote UfInlineMe $3
189 -- | '%external' STRING aty { External $2 $3 }
191 alts1 :: { [UfAlt RdrName] }
193 | alt ';' alts1 { $1:$3 }
195 alt :: { UfAlt RdrName }
196 : q_d_name attbinds vbinds '->' exp
197 { {- ToDo: sort out-} (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) }
199 { (UfLitAlt $1, [], $3) }
201 { (UfDefault, [], $3) }
204 : '(' INTEGER '::' aty ')' { MachInt $2 }
205 | '(' RATIONAL '::' aty ')' { MachDouble $2 }
206 | '(' CHAR '::' aty ')' { MachChar (fromEnum $2) }
207 | '(' STRING '::' aty ')' { MachStr (mkFastString $2) }
210 : NAME { mkRdrUnqual (mkVarOccEncoded (mkFastString $1)) }
218 modid :: { ModuleName }
219 : CNAME { mkSysModuleNameFS (mkFastString $1) }
224 { mkIfaceOrig varName (mkFastString $1,mkFastString $3) }
227 q_tc_name :: { RdrName }
229 { mkIfaceOrig tcName (mkFastString $1,mkFastString $3) }
232 q_d_name :: { RdrName }
234 { mkIfaceOrig dataName (mkFastString $1,mkFastString $3) }
238 toUfBinder :: [RdrNameHsDecl] -> UfBinding RdrName
241 [x] -> uncurry UfNonRec (conv x)
242 _ -> UfRec (map conv xs)
244 conv (TyClD (CoreDecl n ty rhs _)) = (UfValBinder n ty, rhs)
247 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l