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.

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index d8fdfb5..af30dd1 100644 (file)
--- 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 (file)
--- 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