Merge branch 'master' of http://darcs.haskell.org//haddock

3 files changed, 82 insertions, 47 deletions

diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index a4d4764e..86d1a7b8 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -53,7 +53,7 @@ attachToExportItem :: Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -
 attachToExportItem iface ifaceMap instIfaceMap export =
   case export of
     ExportDecl { expItemDecl = L _ (TyClD d) } -> do
-      mb_info <- getAllInfo (unLoc (tcdLName d))
+      mb_info <- getAllInfo (tcdName d)
       let export' =
             export {
               expItemInstances =
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 9fca453d..8f429d9c 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -268,7 +268,7 @@ mkMaps dflags gre instances decls = do
     instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ]
 
     names :: HsDecl Name -> [Name]
-    names (InstD (ClsInstD { cid_poly_ty = L l _ })) = maybeToList (M.lookup l instanceMap)  -- See note [2].
+    names (InstD (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ }))) = maybeToList (M.lookup l instanceMap)  -- See note [2].
     names decl = getMainDeclBinder decl
 
 -- Note [2]:
@@ -296,7 +296,7 @@ subordinates (TyClD decl)
                 ]
     dataSubs = constrs ++ fields
       where
-        cons = map unL $ (td_cons (tcdTyDefn decl))
+        cons = map unL $ (dd_cons (tcdDataDefn decl))
         constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty)
                   | c <- cons ]
         fields  = [ (unL n, maybeToList $ fmap unL doc, M.empty)
@@ -312,7 +312,7 @@ typeDocs d =
   case d of
     SigD (TypeSig _ ty) -> docs (unLoc ty)
     ForD (ForeignImport _ ty _ _) -> docs (unLoc ty)
-    TyClD (TyDecl { tcdTyDefn = TySynonym {td_synRhs = ty}}) -> docs (unLoc ty)
+    TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)
     _ -> M.empty
   where
     go n (HsForAllTy _ _ _ ty) = go n (unLoc ty)
@@ -331,7 +331,7 @@ classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
     docs  = mkDecls tcdDocs DocD class_
     defs  = mkDecls (bagToList . tcdMeths) ValD class_
     sigs  = mkDecls tcdSigs SigD class_
-    ats   = mkDecls tcdATs TyClD class_
+    ats   = mkDecls tcdATs (TyClD . FamDecl) class_
 
 
 -- | The top-level declarations of a module that we care about,
@@ -374,7 +374,11 @@ warnAboutFilteredDecls :: DynFlags -> Module -> [LHsDecl Name] -> ErrMsgM ()
 warnAboutFilteredDecls dflags mdl decls = do
   let modStr = moduleString mdl
   let typeInstances =
-        nub [ unLoc (fid_tycon d) | L _ (InstD (FamInstD { lid_inst = d })) <- decls ]
+        nub (concat [[ unLoc (tfie_tycon eqn)
+                     | L _ (InstD (TyFamInstD (TyFamInstDecl { tfid_eqns = eqns }))) <- decls
+                     , L _ eqn <- eqns ],
+                     [ unLoc (dfid_tycon d)
+                     | L _ (InstD (DataFamInstD { dfid_inst = d })) <- decls ]])
 
   unless (null typeInstances) $
     tell [
@@ -383,8 +387,11 @@ warnAboutFilteredDecls dflags mdl decls = do
       ++ "will be filtered out:\n  " ++ (intercalate ", "
       $ map (occNameString . nameOccName) typeInstances) ]
 
-  let instances = nub [ pretty dflags i | L _ (InstD (ClsInstD { cid_poly_ty = i, cid_fam_insts = ats })) <- decls
-                                 , not (null ats) ]
+  let instances = nub [ pretty dflags i | L _ (InstD (ClsInstD (ClsInstDecl
+                                                { cid_poly_ty = i
+                                                , cid_tyfam_insts = ats
+                                                , cid_datafam_insts = adts }))) <- decls
+                                 , not (null ats) || not (null adts) ]
 
   unless (null instances) $
     tell [
@@ -734,11 +741,11 @@ extractDecl name mdl decl
           _ -> error "internal: extractDecl"
       TyClD d | isDataDecl d ->
         let (n, tyvar_names) = name_and_tyvars d
-            L pos sig = extractRecSel name mdl n tyvar_names (td_cons (tcdTyDefn d))
+            L pos sig = extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d))
         in L pos (SigD sig)
       _ -> error "internal: extractDecl"
   where
-    name_and_tyvars d = (unLoc (tcdLName d), hsLTyVarLocNames (tcdTyVars d))
+    name_and_tyvars d = (tcdName d, hsLTyVarLocNames (tyClDeclTyVars d))
 
 
 toTypeNoLoc :: Located Name -> LHsType Name
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 6109c341..b384886c 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -322,10 +322,8 @@ renameDecl decl = case decl of
     return (InstD d')
   _ -> error "renameDecl"
 
-
-renameLTyClD :: LTyClDecl Name -> RnM (LTyClDecl DocName)
-renameLTyClD (L loc d) = return . L loc =<< renameTyClD d
-
+renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName))
+renameLThing fn (L loc x) = return . L loc =<< fn x
 
 renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName)
 renameTyClD d = case d of
@@ -334,19 +332,21 @@ renameTyClD d = case d of
     return (ForeignType lname' b)
 
 --  TyFamily flav lname ltyvars kind tckind -> do
-  TyFamily flav lname ltyvars tckind -> do
-    lname'   <- renameL lname
-    ltyvars' <- renameLTyVarBndrs ltyvars
---    kind'    <- renameMaybeLKind kind
-    tckind'    <- renameMaybeLKind tckind
---    return (TyFamily flav lname' ltyvars' kind' tckind)
-    return (TyFamily flav lname' ltyvars' tckind')
+  FamDecl { tcdFam = decl } -> do
+    decl' <- renameFamilyDecl decl
+    return (FamDecl { tcdFam = decl' })
+
+  SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = fvs } -> do
+    lname'    <- renameL lname
+    tyvars'   <- renameLTyVarBndrs tyvars
+    rhs'     <- renameLType rhs
+    return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = fvs })
 
-  TyDecl { tcdLName = lname, tcdTyVars = tyvars, tcdTyDefn = defn, tcdFVs = fvs } -> do
+  DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = fvs } -> do
     lname'    <- renameL lname
     tyvars'   <- renameLTyVarBndrs tyvars
-    defn'     <- renameTyDefn defn
-    return (TyDecl { tcdLName = lname', tcdTyVars = tyvars', tcdTyDefn = defn', tcdFVs = fvs })
+    defn'     <- renameDataDefn defn
+    return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = fvs })
 
   ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars
             , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
@@ -355,8 +355,8 @@ renameTyClD d = case d of
     ltyvars'  <- renameLTyVarBndrs ltyvars
     lfundeps' <- mapM renameLFunDep lfundeps
     lsigs'    <- mapM renameLSig lsigs
-    ats'      <- mapM renameLTyClD ats
-    at_defs'  <- mapM (mapM renameFamInstD) at_defs
+    ats'      <- mapM (renameLThing renameFamilyDecl) ats
+    at_defs'  <- mapM (mapM renameTyFamInstD) at_defs
     -- we don't need the default methods or the already collected doc entities
     return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'
                       , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag
@@ -370,19 +370,24 @@ renameTyClD d = case d of
 
     renameLSig (L loc sig) = return . L loc =<< renameSig sig
 
-renameTyDefn :: HsTyDefn Name -> RnM (HsTyDefn DocName)
-renameTyDefn (TyData { td_ND = nd, td_ctxt = lcontext, td_cType = cType
-                     , td_kindSig = k, td_cons = cons }) = do
+renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName)
+renameFamilyDecl (FamilyDecl { fdFlavour = flav, fdLName = lname
+                             , fdTyVars = ltyvars, fdKindSig = tckind }) = do
+    lname'   <- renameL lname
+    ltyvars' <- renameLTyVarBndrs ltyvars
+    tckind'  <- renameMaybeLKind tckind
+    return (FamilyDecl { fdFlavour = flav, fdLName = lname'
+                       , fdTyVars = ltyvars', fdKindSig = tckind' })
+
+renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName)
+renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
+                           , dd_kindSig = k, dd_cons = cons }) = do
     lcontext' <- renameLContext lcontext
     k'        <- renameMaybeLKind k
     cons'     <- mapM (mapM renameCon) cons
     -- I don't think we need the derivings, so we return Nothing
-    return (TyData { td_ND = nd, td_ctxt = lcontext', td_cType = cType
-                   , td_kindSig = k', td_cons = cons', td_derivs = Nothing })
-
-renameTyDefn (TySynonym { td_synRhs = ltype }) = do
-    ltype'   <- renameLType ltype
-    return (TySynonym { td_synRhs = ltype' })
+    return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType
+                       , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing })
 
 renameCon :: ConDecl Name -> RnM (ConDecl DocName)
 renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars
@@ -435,24 +440,47 @@ renameForD (ForeignExport lname ltype co x) = do
 
 
 renameInstD :: InstDecl Name -> RnM (InstDecl DocName)
-renameInstD (ClsInstD { cid_poly_ty =ltype, cid_fam_insts = lATs }) = do
+renameInstD (ClsInstD { cid_inst = d }) = do
+  d' <- renameClsInstD d
+  return (ClsInstD { cid_inst = d' })
+renameInstD (TyFamInstD { tfid_inst = d }) = do
+  d' <- renameTyFamInstD d
+  return (TyFamInstD { tfid_inst = d' })
+renameInstD (DataFamInstD { dfid_inst = d }) = do
+  d' <- renameDataFamInstD d
+  return (DataFamInstD { dfid_inst = d' })
+
+renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName)
+renameClsInstD (ClsInstDecl { cid_poly_ty =ltype, cid_tyfam_insts = lATs, cid_datafam_insts = lADTs }) = do
   ltype' <- renameLType ltype
-  lATs' <- mapM (mapM renameFamInstD) lATs
-  return (ClsInstD { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = []
-                   , cid_fam_insts = lATs' })
+  lATs'  <- mapM (mapM renameTyFamInstD) lATs
+  lADTs' <- mapM (mapM renameDataFamInstD) lADTs
+  return (ClsInstDecl { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = []
+                      , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' })
 
-renameInstD (FamInstD { lid_inst = d }) = do
-  d' <- renameFamInstD d
-  return (FamInstD { lid_inst = d' })
 
-renameFamInstD :: FamInstDecl Name -> RnM (FamInstDecl DocName)
-renameFamInstD (FamInstDecl { fid_tycon = tc, fid_pats = pats_w_bndrs, fid_defn = defn })
+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
+                               , tfid_fvs = placeHolderNames }) }
+
+renameTyFamInstEqn :: TyFamInstEqn Name -> RnM (TyFamInstEqn DocName)
+renameTyFamInstEqn (TyFamInstEqn { tfie_tycon = tc, tfie_pats = pats_w_bndrs, tfie_rhs = rhs })
   = do { tc' <- renameL tc
        ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
-       ; defn' <- renameTyDefn defn 
-       ; return (FamInstDecl { fid_tycon = tc', fid_pats = pats_w_bndrs { hswb_cts = pats' }
-                             , fid_defn = defn', fid_fvs = placeHolderNames }) }
+       ; rhs' <- renameLType rhs 
+       ; return (TyFamInstEqn { tfie_tycon = tc', tfie_pats = pats_w_bndrs { hswb_cts = pats' }
+                              , tfie_rhs = rhs' }) }
 
+renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)
+renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn })
+  = do { tc' <- renameL tc
+       ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
+       ; defn' <- renameDataDefn defn 
+       ; return (DataFamInstDecl { dfid_tycon = tc', dfid_pats = pats_w_bndrs { hswb_cts = pats' }
+                                 , dfid_defn = defn', dfid_fvs = placeHolderNames }) }
 
 renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
 renameExportItem item = case item of