X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParserCore.y;h=1cd7d6a6bf66f627d4558ff094cd3a3a37d548d9;hb=d28ba8c800901bea01f70c4719278c2a364cf9fc;hp=9d45fad1de07a9510e6776d2fcae3f94104cb755;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git

diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y
index 9d45fad..1cd7d6a 100644
--- a/ghc/compiler/parser/ParserCore.y
+++ b/ghc/compiler/parser/ParserCore.y
@@ -15,7 +15,9 @@ import Literal
 import BasicTypes
 import Type
 import SrcLoc
+import PrelNames
 import FastString
+import Outputable
 
 #include "../HsVersions.h"
 
@@ -66,7 +68,7 @@ import FastString
 
 module	:: { RdrNameHsModule }
 	: '%module' modid tdefs vdefgs
-		{ HsModule (mkHomeModule $2) Nothing Nothing 
+		{ HsModule (Just (mkHomeModule $2)) Nothing 
 		           [] ($3 ++ concat $4) Nothing noSrcLoc}
 
 tdefs	:: { [RdrNameHsDecl] }
@@ -77,11 +79,15 @@ tdef	:: { RdrNameHsDecl }
 	: '%data' q_tc_name tbinds '=' '{' cons1 '}'
                 { TyClD (mkTyData DataType ([], $2, $3) (DataCons $6) Nothing noSrcLoc) }
 	| '%newtype' q_tc_name tbinds trep 
-		{ TyClD (mkTyData NewType ([], $2, $3) ($4 $2 $3) Nothing noSrcLoc) }
+		{ TyClD (mkTyData NewType ([], $2, $3) ($4 $2) Nothing noSrcLoc) }
 
-trep    :: { (RdrName -> [HsTyVarBndr RdrName] -> DataConDetails (ConDecl RdrName)) }
-        : {- empty -}   { (\ x ts -> Unknown) }
-        | '=' ty        { (\ x ts -> DataCons [ConDecl x ts [] (PrefixCon [unbangedType $2]) noSrcLoc]) }
+-- For a newtype we have to invent a fake data constructor name
+-- It doesn't matter what it is, because it won't be used
+trep    :: { (RdrName -> DataConDetails (ConDecl RdrName)) }
+        : {- empty -}   { (\ tc_name -> Unknown) }
+        | '=' ty        { (\ tc_name -> let { dc_name  = setRdrNameSpace tc_name dataName ;
+			                      con_info = PrefixCon [unbangedType $2] }
+			                in DataCons [ConDecl dc_name [] [] con_info noSrcLoc]) }
 
 tbind	:: { HsTyVarBndr RdrName }
 	:  name                    { IfaceTyVar $1 liftedTypeKind }
@@ -110,6 +116,8 @@ vdefs1	:: { [RdrNameCoreDecl] }
 
 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) }
@@ -146,7 +154,7 @@ cons1	:: { [ConDecl RdrName] }
 	| con ';' cons1	{ $1:$3 }
 
 con	:: { ConDecl RdrName }
-	: q_d_name attbinds atys 
+	: q_d_patt attbinds atys 
 		{ ConDecl $1 $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc}
 
 atys	:: { [ RdrNameHsType] }
@@ -170,7 +178,6 @@ ty	:: { RdrNameHsType }
 
 aexp    :: { UfExpr RdrName }
 	: qname 	{ UfVar $1 }
-        | q_d_name 	{ UfVar $1 } 
 	| lit		{ UfLit $1 }
 	| '(' exp ')' 	{ $2 }
 
@@ -199,16 +206,16 @@ alts1	:: { [UfAlt RdrName] }
 	| 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 (mkFastString $2) }
 
@@ -224,26 +231,55 @@ mname	:: { String }
 modid	:: { ModuleName }
 	: CNAME	{ mkSysModuleNameFS (mkFastString $1) }
 
-qname	:: { RdrName }
-	: name	{ $1 }
-	| mname '.' NAME
-	  { mkIfaceOrig varName (mkFastString $1,mkFastString $3) }
+qname	:: { RdrName }           -- Includes data constructors
+	: name	                 { $1 }
+	| mname '.' NAME	 { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) }
+        | q_d_occ                { $1 }
+
 
 -- Type constructor
 q_tc_name	:: { RdrName }
         : mname '.' cname 
-		{ mkIfaceOrig tcName (mkFastString $1,mkFastString $3) }
+		{ mkIfaceOrig tcName (mkFastString $1) (mkFastString $3) }
+
+-- 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 (mkFastString $1) (mkFastString $3) }
 
--- Data constructor
-q_d_name	:: { RdrName }
+-- Data constructor occurrence in an expression;
+-- use the varName because that's the worker Id
+q_d_occ :: { RdrName }
         : mname '.' cname 
-		{ mkIfaceOrig dataName (mkFastString $1,mkFastString $3) }
+		{ mkIfaceOrig varName (mkFastString $1) (mkFastString $3) }
 
 
 {
 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
 }