From ce3ff856c9412d5392fb7a5c37445f60f84cb2d2 Mon Sep 17 00:00:00 2001
From: Richard Eisenberg <eir@cis.upenn.edu>
Date: Fri, 21 Jun 2013 14:08:25 +0100
Subject: Updates to reflect changes in HsDecls to support closed type
 families.

---
 src/Haddock/Interface/AttachInstances.hs |  2 +-
 src/Haddock/Interface/Create.hs          | 13 ++++++++-----
 src/Haddock/Interface/Rename.hs          | 19 +++++++++++++------
 3 files changed, 22 insertions(+), 12 deletions(-)

(limited to 'src/Haddock/Interface')

diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index 62d08021..03d463cb 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -116,7 +116,7 @@ dropSilentArgs dfun theta = drop (dfunNSilent dfun) theta
 
 -- | Like GHC's getInfo but doesn't cut things out depending on the
 -- interative context, which we don't set sufficiently anyway.
-getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst Branched]))
+getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst]))
 getAllInfo name = withSession $ \hsc_env -> do 
    (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name
    return r
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 40016a0b..d4adbe1c 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -385,16 +385,19 @@ warnAboutFilteredDecls :: DynFlags -> Module -> [LHsDecl Name] -> ErrMsgM ()
 warnAboutFilteredDecls dflags mdl decls = do
   let modStr = moduleString mdl
   let typeInstances =
-        nub (concat [[ unLoc (tfie_tycon eqn)
-                     | L _ (InstD (TyFamInstD (TyFamInstDecl { tfid_eqns = eqns }))) <- decls
-                     , L _ eqn <- eqns ],
+        nub (concat [[ unLoc (tfie_tycon (unLoc eqn))
+                     | L _ (InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = eqn }))) <- decls ],
                      [ unLoc (dfid_tycon d)
-                     | L _ (InstD (DataFamInstD { dfid_inst = d })) <- decls ]])
+                     | L _ (InstD (DataFamInstD { dfid_inst = d })) <- decls ],
+                     [ unLoc tc
+                     | L _ (TyClD (FamDecl (FamilyDecl { fdInfo = ClosedTypeFamily _
+                                                       , fdLName = tc }))) <- decls ]])
 
   unless (null typeInstances) $
     tell [
       "Warning: " ++ modStr ++ ": Instances of type and data "
-      ++ "families are not yet supported. Instances of the following families "
+      ++ "families and equations of closed type families are not yet supported."
+      ++ "Instances of the following families "
       ++ "will be filtered out:\n  " ++ (intercalate ", "
       $ map (occNameString . nameOccName) typeInstances) ]
 
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index a2499726..f21088d8 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -379,14 +379,22 @@ renameTyClD d = case d of
     renameLSig (L loc sig) = return . L loc =<< renameSig sig
 
 renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName)
-renameFamilyDecl (FamilyDecl { fdFlavour = flav, fdLName = lname
+renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
                              , fdTyVars = ltyvars, fdKindSig = tckind }) = do
+    info'    <- renameFamilyInfo info
     lname'   <- renameL lname
     ltyvars' <- renameLTyVarBndrs ltyvars
     tckind'  <- renameMaybeLKind tckind
-    return (FamilyDecl { fdFlavour = flav, fdLName = lname'
+    return (FamilyDecl { fdInfo = info', fdLName = lname'
                        , fdTyVars = ltyvars', fdKindSig = tckind' })
 
+renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName)
+renameFamilyInfo DataFamily     = return DataFamily
+renameFamilyInfo OpenTypeFamily = return OpenTypeFamily
+renameFamilyInfo (ClosedTypeFamily eqns)
+  = do { eqns' <- mapM (renameLThing renameTyFamInstEqn) eqns
+       ; return $ ClosedTypeFamily eqns' }
+
 renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName)
 renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
                            , dd_kindSig = k, dd_cons = cons }) = do
@@ -471,10 +479,9 @@ renameClsInstD (ClsInstDecl { cid_poly_ty =ltype, cid_tyfam_insts = lATs, cid_da
 
 
 renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName)
-renameTyFamInstD (TyFamInstDecl { tfid_eqns = eqns , tfid_group = eqn_group })
-  = do { eqns' <- mapM (renameLThing renameTyFamInstEqn) eqns
-       ; return (TyFamInstDecl { tfid_eqns = eqns'
-                               , tfid_group = eqn_group
+renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
+  = do { eqn' <- renameLThing renameTyFamInstEqn eqn
+       ; return (TyFamInstDecl { tfid_eqn = eqn'
                                , tfid_fvs = placeHolderNames }) }
 
 renameTyFamInstEqn :: TyFamInstEqn Name -> RnM (TyFamInstEqn DocName)
-- 
cgit v1.2.3