From: simonpj <unknown>
Date: Fri, 3 Dec 2004 13:47:22 +0000 (+0000)
Subject: [project @ 2004-12-03 13:47:22 by simonpj]
X-Git-Tag: Initial_conversion_from_CVS_complete~1366
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=6601043cadef1b5b320ce4874d2ba382462241ac;p=ghc-hetmet.git

[project @ 2004-12-03 13:47:22 by simonpj]
TH refication for primitive TyCons
---

diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs
index f403927..0a7ae7f 100644
--- a/ghc/compiler/typecheck/TcSplice.lhs
+++ b/ghc/compiler/typecheck/TcSplice.lhs
@@ -45,7 +45,8 @@ import TcRnMonad
 import IfaceEnv		( lookupOrig )
 import Class		( Class, classExtraBigSig )
 import TyCon		( TyCon, AlgTyConRhs(..), tyConTyVars, getSynTyConDefn, 
-			  isSynTyCon, isNewTyCon, tyConDataCons, algTyConRhs )
+			  isSynTyCon, isNewTyCon, tyConDataCons, algTyConRhs, isPrimTyCon, isFunTyCon,
+			  tyConArity, isUnLiftedTyCon )
 import DataCon		( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks, 
 			  dataConName, dataConFieldLabels, dataConWrapId, dataConIsInfix, 
 			  isVanillaDataCon )
@@ -540,8 +541,8 @@ reifyThing (AGlobal (AnId id))
 	    other	     -> return (TH.VarI     v ty Nothing fix)
     }
 
-reifyThing (AGlobal (ATyCon tc))   = do { dec <- reifyTyCon tc;  return (TH.TyConI dec) }
-reifyThing (AGlobal (AClass cls))  = do { dec <- reifyClass cls; return (TH.ClassI dec) }
+reifyThing (AGlobal (ATyCon tc))  = reifyTyCon tc
+reifyThing (AGlobal (AClass cls)) = reifyClass cls
 reifyThing (AGlobal (ADataCon dc))
   = do	{ let name = dataConName dc
 	; ty <- reifyType (idType (dataConWrapId dc))
@@ -561,25 +562,27 @@ reifyThing (ATyVar tv)
 	; return (TH.TyVarI (reifyName tv) ty2) }
 
 ------------------------------
-reifyTyCon :: TyCon -> TcM TH.Dec
+reifyTyCon :: TyCon -> TcM TH.Info
 reifyTyCon tc
+  | isFunTyCon tc  = return (TH.PrimTyConI (reifyName tc) 2 		  False)
+  | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
   | isSynTyCon tc
   = do	{ let (tvs, rhs) = getSynTyConDefn tc
 	; rhs' <- reifyType rhs
-	; return (TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
+	; return (TH.TyConI $ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
 
 reifyTyCon tc
   = case algTyConRhs tc of
       NewTyCon data_con _ _ 
 	-> do	{ con <- reifyDataCon data_con
-		; return (TH.NewtypeD [] (reifyName tc) (reifyTyVars (tyConTyVars tc))
-				      con [{- Don't know about deriving -}]) }
+		; return (TH.TyConI $ TH.NewtypeD [] (reifyName tc) (reifyTyVars (tyConTyVars tc))
+				      		  con [{- Don't know about deriving -}]) }
 
       DataTyCon mb_cxt cons _
 	-> do	{ cxt <- reifyCxt (mb_cxt `orElse` [])
 		; cons <- mapM reifyDataCon (tyConDataCons tc)
-		; return (TH.DataD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc))
-				      cons [{- Don't know about deriving -}]) }
+		; return (TH.TyConI $ TH.DataD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc))
+				      	       cons [{- Don't know about deriving -}]) }
 
 reifyDataCon :: DataCon -> TcM TH.Con
 reifyDataCon dc
@@ -604,11 +607,11 @@ reifyDataCon dc
 		<+> quotes (ppr dc))
 
 ------------------------------
-reifyClass :: Class -> TcM TH.Dec
+reifyClass :: Class -> TcM TH.Info
 reifyClass cls 
   = do	{ cxt <- reifyCxt theta
 	; ops <- mapM reify_op op_stuff
-	; return (TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
+	; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
   where
     (tvs, fds, theta, _, op_stuff) = classExtraBigSig cls
     fds' = map reifyFunDep fds