[project @ 2003-05-21 02:58:39 by igloo]

Added support for newtypes to TH and altered a test for them.

ghc/compiler/deSugar/DsMeta.hs

@@ -219,6 +219,18 @@ repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt,
       	       repData cxt1 tc1 (coreList' stringTy bndrs) cons2 derivs1 } ;
         return $ Just (loc, dec) }
 
+repTyClD' (TyData { tcdND = NewType, tcdCtxt = cxt, 
+		   tcdName = tc, tcdTyVars = tvs, 
+		   tcdCons = DataCons [con], tcdDerivs = mb_derivs,
+           tcdLoc = loc}) 
+ = do { tc1 <- lookupOcc tc ;		-- See note [Binders and occurrences] 
+        dec <- addTyVarBinds tvs $ \bndrs -> do {
+      	       cxt1   <- repContext cxt ;
+               con1   <- repC con ;
+      	       derivs1 <- repDerivs mb_derivs ;
+      	       repNewtype cxt1 tc1 (coreList' stringTy bndrs) con1 derivs1 } ;
+        return $ Just (loc, dec) }
+
 repTyClD' (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty,
            tcdLoc = loc})
  = do { tc1 <- lookupOcc tc ;		-- See note [Binders and occurrences] 
@@ -1049,6 +1061,9 @@ repFun (MkC nm) (MkC b) = rep2 funName [nm, b]
 repData :: Core M.CxtQ -> Core String -> Core [String] -> Core [M.ConQ] -> Core [String] -> DsM (Core M.DecQ)
 repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [cxt, nm, tvs, cons, derivs]
 
+repNewtype :: Core M.CxtQ -> Core String -> Core [String] -> Core M.ConQ -> Core [String] -> DsM (Core M.DecQ)
+repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs) = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
+
 repTySyn :: Core String -> Core [String] -> Core M.TypQ -> DsM (Core M.DecQ)
 repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
 
@@ -1225,7 +1240,7 @@ templateHaskellNames
 		fromName, fromThenName, fromToName, fromThenToName,
 		funName, valName, liftName,
 	  	gensymName, returnQName, bindQName, sequenceQName,
-		matchName, clauseName, funName, valName, tySynDName, dataDName, classDName,
+		matchName, clauseName, funName, valName, tySynDName, dataDName, newtypeDName, classDName,
 		instName, protoName, tforallName, tvarName, tconName, tappName,
 		arrowTyConName, tupleTyConName, listTyConName, namedTyConName,
 		ctxtName, constrName, recConstrName, infixConstrName,
@@ -1309,6 +1324,7 @@ clauseName     = varQual FSLIT("clause")        clauseIdKey
 funName        = varQual FSLIT("fun")           funIdKey
 valName        = varQual FSLIT("val")           valIdKey
 dataDName      = varQual FSLIT("dataD")         dataDIdKey
+newtypeDName   = varQual FSLIT("newtypeD")      newtypeDIdKey
 tySynDName     = varQual FSLIT("tySynD")        tySynDIdKey
 classDName     = varQual FSLIT("classD")        classDIdKey
 instName       = varQual FSLIT("inst")          instIdKey
@@ -1480,6 +1496,8 @@ intPrimLIdKey    = mkPreludeMiscIdUnique 275
 floatPrimLIdKey  = mkPreludeMiscIdUnique 276
 doublePrimLIdKey = mkPreludeMiscIdUnique 277
 
+newtypeDIdKey      = mkPreludeMiscIdUnique 278
+
 -- %************************************************************************
 -- %*									*
 --		Other utilities

ghc/compiler/hsSyn/Convert.lhs

@@ -46,6 +46,27 @@ import Outputable
 convertToHsDecls :: [Meta.Dec] -> [Either (HsDecl RdrName) Message]
 convertToHsDecls ds = map cvt_top ds
 
+mk_con con = case con of
+	Constr c strtys
+	 -> ConDecl (cName c) noExistentials noContext
+		  (PrefixCon (map mk_arg strtys)) loc0
+	RecConstr c varstrtys
+	 -> ConDecl (cName c) noExistentials noContext
+		  (Hs.RecCon (map mk_id_arg varstrtys)) loc0
+	InfixConstr st1 c st2
+	 -> ConDecl (cName c) noExistentials noContext
+		  (InfixCon (mk_arg st1) (mk_arg st2)) loc0
+  where
+    mk_arg (Strict, ty) = BangType MarkedUserStrict (cvtType ty)
+    mk_arg (NonStrict, ty) = BangType NotMarkedStrict (cvtType ty)
+
+    mk_id_arg (i, Strict, ty)
+        = (vName i, BangType MarkedUserStrict (cvtType ty))
+    mk_id_arg (i, NonStrict, ty)
+        = (vName i, BangType NotMarkedStrict (cvtType ty))
+
+mk_derivs [] = Nothing
+mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs]
 
 cvt_top :: Meta.Dec -> Either (HsDecl RdrName) Message
 cvt_top d@(Val _ _ _) = Left $ ValD (cvtd d)
@@ -59,27 +80,12 @@ cvt_top (Data ctxt tc tvs constrs derivs)
                            (cvt_context ctxt, tconName tc, cvt_tvs tvs)
                            (DataCons (map mk_con constrs))
                            (mk_derivs derivs) loc0)
-  where
-    mk_con (Constr c strtys)
-	= ConDecl (cName c) noExistentials noContext
-		  (PrefixCon (map mk_arg strtys)) loc0
-    mk_con (RecConstr c varstrtys)
-	= ConDecl (cName c) noExistentials noContext
-		  (Hs.RecCon (map mk_id_arg varstrtys)) loc0
-    mk_con (InfixConstr st1 c st2)
-	= ConDecl (cName c) noExistentials noContext
-		  (InfixCon (mk_arg st1) (mk_arg st2)) loc0
 
-    mk_arg (Strict, ty) = BangType MarkedUserStrict (cvtType ty)
-    mk_arg (NonStrict, ty) = BangType NotMarkedStrict (cvtType ty)
-
-    mk_id_arg (i, Strict, ty)
-        = (vName i, BangType MarkedUserStrict (cvtType ty))
-    mk_id_arg (i, NonStrict, ty)
-        = (vName i, BangType NotMarkedStrict (cvtType ty))
-
-    mk_derivs [] = Nothing
-    mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs]
+cvt_top (Newtype ctxt tc tvs constr derivs)
+  = Left $ TyClD (mkTyData NewType 
+                           (cvt_context ctxt, tconName tc, cvt_tvs tvs)
+                           (DataCons [mk_con constr])
+                           (mk_derivs derivs) loc0)
 
 cvt_top (Class ctxt cl tvs decs)
   = Left $ TyClD (mkClassDecl (cvt_context ctxt, tconName cl, cvt_tvs tvs)