From 3517c53d8a66149dcc3f971cf0577719e99d6d70 Mon Sep 17 00:00:00 2001
From: Manuel M T Chakravarty <chak@cse.unsw.edu.au>
Date: Wed, 25 Mar 2009 03:34:47 +0000
Subject: [PATCH] Template Haskell: make reify aware of type families -
 Reifying a type family returns a TH family declaration -
 Reifying a data constructor from a data instance attributes
 that   constructor to the family (not the representation
 tycon) - Ideally, we should have facilities to reify all
 type/data instances of a   given family (and the same for
 instances of a class).  I haven't added that   here as it
 involves some API design.

---
 compiler/basicTypes/DataCon.lhs |   14 ++++++++++++--
 compiler/typecheck/TcSplice.lhs |   27 ++++++++++++++++++++++-----
 2 files changed, 34 insertions(+), 7 deletions(-)

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index d8fdfb5..af30dd1 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -15,9 +15,11 @@ module DataCon (
 	
 	-- ** Type deconstruction
 	dataConRepType, dataConSig, dataConFullSig,
-	dataConName, dataConIdentity, dataConTag, dataConTyCon, dataConUserType,
+	dataConName, dataConIdentity, dataConTag, dataConTyCon, 
+        dataConOrigTyCon, dataConUserType,
 	dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, 
-	dataConEqSpec, eqSpecPreds, dataConEqTheta, dataConDictTheta, dataConStupidTheta, 
+	dataConEqSpec, eqSpecPreds, dataConEqTheta, dataConDictTheta,
+	dataConStupidTheta,  
 	dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
 	dataConInstOrigArgTys, dataConRepArgTys, 
 	dataConFieldLabels, dataConFieldType,
@@ -563,6 +565,14 @@ dataConTag  = dcTag
 dataConTyCon :: DataCon -> TyCon
 dataConTyCon = dcRepTyCon
 
+-- | The original type constructor used in the definition of this data
+-- constructor.  In case of a data family instance, that will be the family
+-- type constructor.
+dataConOrigTyCon :: DataCon -> TyCon
+dataConOrigTyCon dc 
+  | Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc
+  | otherwise                                          = dcRepTyCon dc
+
 -- | The representation type of the data constructor, i.e. the sort
 -- type that will represent values of this type at runtime
 dataConRepType :: DataCon -> Type
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 0bdcbbd..e0b5f3d 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -883,7 +883,9 @@ reifyThing (AGlobal (ADataCon dc))
   = do	{ let name = dataConName dc
 	; ty <- reifyType (idType (dataConWrapId dc))
 	; fix <- reifyFixity name
-	; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
+	; return (TH.DataConI (reifyName name) ty 
+                              (reifyName (dataConOrigTyCon dc)) fix) 
+        }
 
 reifyThing (ATcId {tct_id = id, tct_type = ty}) 
   = do	{ ty1 <- zonkTcType ty	-- Make use of all the info we have, even
@@ -902,13 +904,22 @@ reifyThing (AThing {}) = panic "reifyThing AThing"
 ------------------------------
 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))
+  | isFunTyCon tc  
+  = return (TH.PrimTyConI (reifyName tc) 2 		  False)
+  | isPrimTyCon tc 
+  = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
+  | isOpenTyCon tc
+  = let flavour = reifyFamFlavour tc
+        tvs     = tyConTyVars tc
+    in
+    return (TH.TyConI $
+              TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs))
   | isSynTyCon tc
   = do { let (tvs, rhs) = synTyConDefn tc 
        ; rhs' <- reifyType rhs
        ; return (TH.TyConI $ 
-		   TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
+		   TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') 
+       }
 
 reifyTyCon tc
   = do 	{ cxt <- reifyCxt (tyConStupidTheta tc)
@@ -940,7 +951,7 @@ reifyDataCon tys dc
 	  else
 	     return (TH.NormalC name (stricts `zip` arg_tys)) }
   | otherwise
-  = failWithTc (ptext (sLit "Can't reify a non-Haskell-98 data constructor:") 
+  = failWithTc (ptext (sLit "Can't reify a GADT data constructor:") 
 		<+> quotes (ppr dc))
 
 ------------------------------
@@ -977,6 +988,12 @@ reifyCxt   = mapM reifyPred
 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
 
+reifyFamFlavour :: TyCon -> TH.FamFlavour
+reifyFamFlavour tc | isOpenSynTyCon tc = TH.TypeFam
+                   | isOpenTyCon    tc = TH.DataFam
+                   | otherwise         
+                   = panic "TcSplice.reifyFamFlavour: not a type family"
+
 reifyTyVars :: [TyVar] -> [TH.Name]
 reifyTyVars = map reifyName
 
-- 
1.7.10.4