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 (mkHomeModule $2) Nothing Nothing
70 [] ($3 ++ concat $4) Nothing noSrcLoc}
72 tdefs :: { [RdrNameHsDecl] }
74 | tdef ';' tdefs {$1:$3}
76 tdef :: { RdrNameHsDecl }
77 : '%data' q_tc_name tbinds '=' '{' cons1 '}'
78 { TyClD (mkTyData DataType ([], $2, $3) (DataCons $6) Nothing noSrcLoc) }
79 | '%newtype' q_tc_name tbinds trep
80 { TyClD (mkTyData NewType ([], $2, $3) ($4 $2 $3) Nothing noSrcLoc) }
82 trep :: { (RdrName -> [HsTyVarBndr RdrName] -> DataConDetails (ConDecl RdrName)) }
83 : {- empty -} { (\ x ts -> Unknown) }
84 | '=' ty { (\ x ts -> DataCons [ConDecl x ts [] (PrefixCon [unbangedType $2]) noSrcLoc]) }
86 tbind :: { HsTyVarBndr RdrName }
87 : name { IfaceTyVar $1 liftedTypeKind }
88 | '(' name '::' akind ')' { IfaceTyVar $2 $4 }
90 tbinds :: { [HsTyVarBndr RdrName] }
92 | tbind tbinds { $1:$2 }
94 vdefgs :: { [[RdrNameHsDecl]] }
96 | vdefg ';' vdefgs { ($1:$3) }
98 vdefg :: { [RdrNameHsDecl] }
99 : '%rec' '{' vdefs1 '}' { map CoreD $3 }
100 | vdef { [CoreD $1] }
102 let_bind :: { UfBinding RdrName }
103 : '%rec' '{' vdefs1 '}' { UfRec (map convBind $3) }
104 | vdef { let (b,r) = convBind $1
107 vdefs1 :: { [RdrNameCoreDecl] }
109 | vdef ';' vdefs1 { $1:$3 }
111 vdef :: { RdrNameCoreDecl }
112 : qname '::' ty '=' exp { CoreDecl $1 $3 $5 noSrcLoc }
115 vbind :: { (RdrName, RdrNameHsType) }
116 : '(' name '::' ty ')' { ($2,$4) }
118 vbinds :: { [(RdrName, RdrNameHsType)] }
120 | vbind vbinds { $1:$2 }
122 bind :: { UfBinder RdrName }
123 : '@' tbind { let (IfaceTyVar v k) = $2 in UfTyBinder v k }
124 | vbind { let (v,ty) = $1 in UfValBinder v ty }
126 binds1 :: { [UfBinder RdrName] }
128 | bind binds1 { $1:$2 }
130 attbinds :: { [RdrNameHsTyVar] }
132 | '@' tbind attbinds { $2:$3 }
135 : '*' { liftedTypeKind }
136 | '#' { unliftedTypeKind }
137 | '?' { openTypeKind }
138 | '(' kind ')' { $2 }
142 | akind '->' kind { mkArrowKind $1 $3 }
144 cons1 :: { [ConDecl RdrName] }
146 | con ';' cons1 { $1:$3 }
148 con :: { ConDecl RdrName }
149 : q_d_name attbinds atys
150 { ConDecl $1 $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc}
152 atys :: { [ RdrNameHsType] }
156 aty :: { RdrNameHsType }
157 : name { HsTyVar $1 }
158 | q_tc_name { HsTyVar $1 }
162 bty :: { RdrNameHsType }
164 | bty aty { HsAppTy $1 $2 }
166 ty :: { RdrNameHsType }
168 | bty '->' ty { HsFunTy $1 $3 }
169 | '%forall' tbinds '.' ty { HsForAllTy (Just $2) [] $4 }
171 aexp :: { UfExpr RdrName }
173 | q_d_name { UfVar $1 }
177 fexp :: { UfExpr RdrName }
178 : fexp aexp { UfApp $1 $2 }
179 | fexp '@' aty { UfApp $1 (UfType $3) }
182 exp :: { UfExpr RdrName }
184 | '\\' binds1 '->' exp { foldr UfLam $4 $2 }
185 | '%let' let_bind '%in' exp { UfLet $2 $4 }
186 | '%case' aexp '%of' vbind
187 '{' alts1 '}' { UfCase $2 (fst $4) $6 }
188 | '%coerce' aty exp { UfNote (UfCoerce $2) $3 } -- what about the 'from' type?
191 --"SCC" -> UfNote (UfSCC "scc") $3
192 "InlineCall" -> UfNote UfInlineCall $3
193 "InlineMe" -> UfNote UfInlineMe $3
195 -- | '%external' STRING aty { External $2 $3 }
197 alts1 :: { [UfAlt RdrName] }
199 | alt ';' alts1 { $1:$3 }
201 alt :: { UfAlt RdrName }
202 : q_d_name attbinds vbinds '->' exp
203 { {- ToDo: sort out-} (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) }
205 { (UfLitAlt $1, [], $3) }
207 { (UfDefault, [], $3) }
210 : '(' INTEGER '::' aty ')' { MachInt $2 }
211 | '(' RATIONAL '::' aty ')' { MachDouble $2 }
212 | '(' CHAR '::' aty ')' { MachChar (fromEnum $2) }
213 | '(' STRING '::' aty ')' { MachStr (mkFastString $2) }
216 : NAME { mkRdrUnqual (mkVarOccEncoded (mkFastString $1)) }
224 modid :: { ModuleName }
225 : CNAME { mkSysModuleNameFS (mkFastString $1) }
230 { mkIfaceOrig varName (mkFastString $1,mkFastString $3) }
233 q_tc_name :: { RdrName }
235 { mkIfaceOrig tcName (mkFastString $1,mkFastString $3) }
238 q_d_name :: { RdrName }
240 { mkIfaceOrig dataName (mkFastString $1,mkFastString $3) }
244 convBind :: RdrNameCoreDecl -> (UfBinder RdrName, UfExpr RdrName)
245 convBind (CoreDecl n ty rhs _) = (UfValBinder n ty, rhs)
248 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l