import BasicTypes
import Type
import SrcLoc
+import PrelNames
+import FastString
+import Outputable
#include "../HsVersions.h"
module :: { RdrNameHsModule }
: '%module' modid tdefs vdefgs
- { HsModule $2 Nothing Nothing [] ($3 ++ concat $4) Nothing noSrcLoc}
+ { HsModule (mkHomeModule $2) Nothing Nothing
+ [] ($3 ++ concat $4) Nothing noSrcLoc}
tdefs :: { [RdrNameHsDecl] }
: {- empty -} {[]}
tdef :: { RdrNameHsDecl }
: '%data' q_tc_name tbinds '=' '{' cons1 '}'
- { TyClD (TyData DataType [] $2 $3 (DataCons $6) Nothing [] noSrcLoc) }
+ { TyClD (mkTyData DataType ([], $2, $3) (DataCons $6) Nothing noSrcLoc) }
| '%newtype' q_tc_name tbinds trep
- { TyClD (TyData NewType [] $2 $3 ($4 $2 $3) Nothing [] noSrcLoc) }
+ { TyClD (mkTyData NewType ([], $2, $3) ($4 $2 $3) Nothing noSrcLoc) }
trep :: { (RdrName -> [HsTyVarBndr RdrName] -> DataConDetails (ConDecl RdrName)) }
: {- empty -} { (\ x ts -> Unknown) }
- | '=' ty { (\ x ts -> DataCons [ConDecl x x ts [] (VanillaCon [unbangedType $2]) noSrcLoc]) }
+ | '=' ty { (\ x ts -> DataCons [ConDecl x ts [] (PrefixCon [unbangedType $2]) noSrcLoc]) }
tbind :: { HsTyVarBndr RdrName }
: name { IfaceTyVar $1 liftedTypeKind }
| vdefg ';' vdefgs { ($1:$3) }
vdefg :: { [RdrNameHsDecl] }
- : '%rec' '{' vdefs1 '}' { $3 }
- | vdef { [$1] }
+ : '%rec' '{' vdefs1 '}' { map CoreD $3 }
+ | vdef { [CoreD $1] }
-vdefs1 :: { [RdrNameHsDecl] }
+let_bind :: { UfBinding RdrName }
+ : '%rec' '{' vdefs1 '}' { UfRec (map convBind $3) }
+ | vdef { let (b,r) = convBind $1
+ in UfNonRec b r }
+
+vdefs1 :: { [RdrNameCoreDecl] }
: vdef { [$1] }
| vdef ';' vdefs1 { $1:$3 }
-vdef :: { RdrNameHsDecl }
- : qname '::' ty '=' exp { TyClD (CoreDecl $1 $3 $5 noSrcLoc) }
+vdef :: { RdrNameCoreDecl }
+ : qname '::' ty '=' exp { CoreDecl $1 $3 $5 noSrcLoc }
+ -- NB: qname includes data constructors, because
+ -- we allow data-constructor wrappers at top level
vbind :: { (RdrName, RdrNameHsType) }
| con ';' cons1 { $1:$3 }
con :: { ConDecl RdrName }
- : q_d_name attbinds atys
- { ConDecl $1 $1 $2 [] (VanillaCon (map unbangedType $3)) noSrcLoc}
+ : q_d_patt attbinds atys
+ { ConDecl $1 $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc}
atys :: { [ RdrNameHsType] }
: {- empty -} { [] }
aexp :: { UfExpr RdrName }
: qname { UfVar $1 }
- | q_d_name { UfVar $1 }
| lit { UfLit $1 }
| '(' exp ')' { $2 }
exp :: { UfExpr RdrName }
: fexp { $1 }
| '\\' binds1 '->' exp { foldr UfLam $4 $2 }
- | '%let' vdefg '%in' exp { UfLet (toUfBinder $2) $4 }
+ | '%let' let_bind '%in' exp { UfLet $2 $4 }
| '%case' aexp '%of' vbind
'{' alts1 '}' { UfCase $2 (fst $4) $6 }
| '%coerce' aty exp { UfNote (UfCoerce $2) $3 } -- what about the 'from' type?
| alt ';' alts1 { $1:$3 }
alt :: { UfAlt RdrName }
- : q_d_name attbinds vbinds '->' exp
- { {- ToDo: sort out-} (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) }
+ : q_d_patt attbinds vbinds '->' exp
+ { (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) }
| lit '->' exp
{ (UfLitAlt $1, [], $3) }
| '%_' '->' exp
{ (UfDefault, [], $3) }
lit :: { Literal }
- : '(' INTEGER '::' aty ')' { MachInt $2 }
- | '(' RATIONAL '::' aty ')' { MachDouble $2 }
+ : '(' INTEGER '::' aty ')' { convIntLit $2 $4 }
+ | '(' RATIONAL '::' aty ')' { convRatLit $2 $4 }
| '(' CHAR '::' aty ')' { MachChar (fromEnum $2) }
- | '(' STRING '::' aty ')' { MachStr (_PK_ $2) }
+ | '(' STRING '::' aty ')' { MachStr (mkFastString $2) }
name :: { RdrName }
- : NAME { mkRdrUnqual (mkVarOccEncoded (_PK_ $1)) }
+ : NAME { mkRdrUnqual (mkVarOccEncoded (mkFastString $1)) }
cname :: { String }
: CNAME { $1 }
: CNAME { $1 }
modid :: { ModuleName }
- : CNAME { mkSysModuleNameFS (_PK_ $1) }
+ : CNAME { mkSysModuleNameFS (mkFastString $1) }
+
+qname :: { RdrName } -- Includes data constructors
+ : name { $1 }
+ | mname '.' NAME { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) }
+ | q_d_occ { $1 }
-qname :: { RdrName }
- : name { $1 }
- | mname '.' NAME
- { mkIfaceOrig varName (_PK_ $1,_PK_ $3) }
-- Type constructor
q_tc_name :: { RdrName }
: mname '.' cname
- { mkIfaceOrig tcName (_PK_ $1,_PK_ $3) }
+ { mkIfaceOrig tcName (mkFastString $1) (mkFastString $3) }
--- Data constructor
-q_d_name :: { RdrName }
+-- Data constructor in a pattern or data type declaration; use the dataName,
+-- because that's what we expect in Core case patterns
+q_d_patt :: { RdrName }
: mname '.' cname
- { mkIfaceOrig dataName (_PK_ $1,_PK_ $3) }
+ { mkIfaceOrig dataName (mkFastString $1) (mkFastString $3) }
+
+-- Data constructor occurrence in an expression;
+-- use the varName because that's the worker Id
+q_d_occ :: { RdrName }
+ : mname '.' cname
+ { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) }
{
-toUfBinder :: [RdrNameHsDecl] -> UfBinding RdrName
-toUfBinder xs =
- case xs of
- [x] -> uncurry UfNonRec (conv x)
- _ -> UfRec (map conv xs)
- where
- conv (TyClD (CoreDecl n ty rhs _)) = (UfValBinder n ty, rhs)
+convBind :: RdrNameCoreDecl -> (UfBinder RdrName, UfExpr RdrName)
+convBind (CoreDecl n ty rhs _) = (UfValBinder n ty, rhs)
+
+convIntLit :: Integer -> RdrNameHsType -> Literal
+convIntLit i (HsTyVar n)
+ | n == intPrimRdrName = MachInt i
+ | n == wordPrimRdrName = MachWord i
+convIntLit i aty
+ = pprPanic "Unknown integer literal type" (ppr aty $$ ppr intPrimRdrName)
+
+convRatLit :: Rational -> RdrNameHsType -> Literal
+convRatLit r (HsTyVar n)
+ | n == floatPrimRdrName = MachFloat r
+ | n == doublePrimRdrName = MachDouble r
+convRatLit i aty
+ = pprPanic "Unknown rational literal type" (ppr aty $$ ppr intPrimRdrName)
+
+
+wordPrimRdrName, intPrimRdrName, floatPrimRdrName, doublePrimRdrName :: RdrName
+wordPrimRdrName = nameRdrName wordPrimTyConName
+intPrimRdrName = nameRdrName intPrimTyConName
+floatPrimRdrName = nameRdrName floatPrimTyConName
+doublePrimRdrName = nameRdrName doublePrimTyConName
happyError :: P a
happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
-
}