2 module ParserCore ( parseCore ) where
12 import ParserCoreUtils
19 #include "../HsVersions.h"
27 '%module' { TKmodule }
28 '%import' { TKimport }
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 imports tdefs vdefgs
69 { HsModule $2 Nothing Nothing $3 ($4 ++ concat $5) Nothing noSrcLoc}
71 imports :: { [ImportDecl RdrName] }
73 | imp ';' imports { $1 : $3 }
75 imp :: { ImportDecl RdrName }
76 : '%import' modid { ImportDecl $2 ImportByUser True{-qual-} Nothing Nothing noSrcLoc }
78 tdefs :: { [RdrNameHsDecl] }
80 | tdef ';' tdefs {$1:$3}
82 tdef :: { RdrNameHsDecl }
83 : '%data' qcname tbinds '=' '{' cons1 '}'
84 { TyClD (TyData DataType [] $2 $3 (DataCons $6) Nothing [] noSrcLoc) }
85 | '%newtype' qcname tbinds trep
86 { TyClD (TyData NewType [] $2 $3 ($4 $2 $3) Nothing [] noSrcLoc) }
88 trep :: { (RdrName -> [HsTyVarBndr RdrName] -> DataConDetails (ConDecl RdrName)) }
89 : {- empty -} { (\ x ts -> Unknown) }
90 | '=' ty { (\ x ts -> DataCons [ConDecl x x ts [] (VanillaCon [unbangedType $2]) 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 '}' { $3 }
108 vdefs1 :: { [RdrNameHsDecl] }
110 | vdef ';' vdefs1 { $1:$3 }
112 vdef :: { RdrNameHsDecl }
113 : qname '::' ty '=' exp { TyClD (CoreDecl $1 $3 $5 noSrcLoc) }
116 vbind :: { (RdrName, RdrNameHsType) }
117 : '(' name '::' ty ')' { ($2,$4) }
119 vbinds :: { [(RdrName, RdrNameHsType)] }
121 | vbind vbinds { $1:$2 }
123 bind :: { UfBinder RdrName }
124 : '@' tbind { let (IfaceTyVar v k) = $2 in UfTyBinder v k }
125 | vbind { let (v,ty) = $1 in UfValBinder v ty }
127 binds1 :: { [UfBinder RdrName] }
129 | bind binds1 { $1:$2 }
131 attbinds :: { [RdrNameHsTyVar] }
133 | '@' tbind attbinds { $2:$3 }
136 : '*' { liftedTypeKind }
137 | '#' { unliftedTypeKind }
138 | '?' { openTypeKind }
139 | '(' kind ')' { $2 }
143 | akind '->' kind { mkArrowKind $1 $3 }
145 cons1 :: { [ConDecl RdrName] }
147 | con ';' cons1 { $1:$3 }
149 con :: { ConDecl RdrName }
150 : qcname attbinds atys
151 { ConDecl $1 $1 $2 [] (VanillaCon (map unbangedType $3)) noSrcLoc}
153 atys :: { [ RdrNameHsType] }
157 aty :: { RdrNameHsType }
158 : name { HsTyVar $1 }
159 | qcname { HsTyVar $1 }
163 bty :: { RdrNameHsType }
165 | bty aty { HsAppTy $1 $2 }
167 ty :: { RdrNameHsType }
169 | bty '->' ty { HsFunTy $1 $3 }
170 | '%forall' tbinds '.' ty { HsForAllTy (Just $2) [] $4 }
172 aexp :: { UfExpr RdrName }
174 | qcname { UfVar $1 }
178 fexp :: { UfExpr RdrName }
179 : fexp aexp { UfApp $1 $2 }
180 | fexp '@' aty { UfApp $1 (UfType $3) }
183 exp :: { UfExpr RdrName }
185 | '\\' binds1 '->' exp { foldr UfLam $4 $2 }
186 | '%let' vdefg '%in' exp { UfLet (toUfBinder $2) $4 }
187 | '%case' aexp '%of' vbind
188 '{' alts1 '}' { UfCase $2 (fst $4) $6 }
189 | '%coerce' aty exp { UfNote (UfCoerce $2) $3 } -- what about the 'from' type?
192 --"SCC" -> UfNote (UfSCC "scc") $3
193 "InlineCall" -> UfNote UfInlineCall $3
194 "InlineMe" -> UfNote UfInlineMe $3
196 -- | '%external' STRING aty { External $2 $3 }
198 alts1 :: { [UfAlt RdrName] }
200 | alt ';' alts1 { $1:$3 }
202 alt :: { UfAlt RdrName }
203 : qcname attbinds vbinds '->' exp
204 { {- ToDo: sort out-} (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) }
206 { (UfLitAlt $1, [], $3) }
208 { (UfDefault, [], $3) }
211 : '(' INTEGER '::' aty ')' { MachInt $2 }
212 | '(' RATIONAL '::' aty ')' { MachDouble $2 }
213 | '(' CHAR '::' aty ')' { MachChar (fromEnum $2) }
214 | '(' STRING '::' aty ')' { MachStr (_PK_ $2) }
217 : NAME { mkUnqual varName (_PK_ $1) }
225 modid :: { ModuleName }
226 : CNAME { mkSysModuleNameFS (_PK_ $1) }
231 { mkIfaceOrig varName (_PK_ $1,_PK_ $3) }
233 qcname :: { RdrName }
235 { mkIfaceOrig dataName (_PK_ $1,_PK_ $3) }
240 toUfBinder :: [RdrNameHsDecl] -> UfBinding RdrName
243 [x] -> uncurry UfNonRec (conv x)
244 _ -> UfRec (map conv xs)
246 conv (TyClD (CoreDecl n ty rhs _)) = (UfValBinder n ty, rhs)
249 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l