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

4 files changed, 57 insertions, 56 deletions

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 55f6ac1d..4417dc52 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -112,9 +112,8 @@ operator x = x
 ppExport :: DynFlags -> ExportItem Name -> [String]
 ppExport dflags (ExportDecl decl dc subdocs _) = ppDocumentation dflags (fst dc) ++ f (unL decl)
     where
-        f (TyClD d@TyDecl{})
-            | isDataDecl d      = ppData dflags d subdocs
-            | otherwise         = ppSynonym dflags d
+        f (TyClD d@DataDecl{})  = ppData dflags d subdocs
+        f (TyClD d@SynDecl{})   = ppSynonym dflags d
         f (TyClD d@ClassDecl{}) = ppClass dflags d
         f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
         f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
@@ -145,8 +144,8 @@ ppClass dflags x = out dflags x{tcdSigs=[]} :
         f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d
         f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t)
 
-        context = nlHsTyConApp (unL $ tcdLName x)
-            (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tcdTyVars x)))
+        context = nlHsTyConApp (tcdName x)
+            (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x)))
 
 
 ppInstance :: DynFlags -> ClsInst -> [String]
@@ -157,9 +156,9 @@ ppSynonym :: DynFlags -> TyClDecl Name -> [String]
 ppSynonym dflags x = [out dflags x]
 
 ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
-ppData dflags decl@(TyDecl { tcdTyDefn = defn }) subdocs
-    = showData decl{ tcdTyDefn = defn { td_cons=[],td_derivs=Nothing }} :
-      concatMap (ppCtor dflags decl subdocs . unL) (td_cons defn)
+ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs
+    = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=Nothing }} :
+      concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn)
     where
         
         -- GHC gives out "data Bar =", we want to delete the equals
@@ -167,7 +166,7 @@ ppData dflags decl@(TyDecl { tcdTyDefn = defn }) subdocs
         showData d = unwords $ map f $ if last xs == "=" then init xs else xs
             where
                 xs = words $ out dflags d
-                nam = out dflags $ tcdLName d
+                nam = out dflags $ tyClDeclLName d
                 f w = if w == nam then operator nam else w
 ppData _ _ _ = panic "ppData"
 
@@ -196,7 +195,7 @@ ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con)
 
         resType = case con_res con of
             ResTyH98 -> apps $ map (reL . HsTyVar) $ 
-                        unL (tcdLName dat) : [hsTyVarName v | L _ (v@UserTyVar {}) <- hsQTvBndrs $ tcdTyVars dat]
+                        (tcdName dat) : [hsTyVarName v | L _ (v@UserTyVar {}) <- hsQTvBndrs $ tyClDeclTyVars dat]
             ResTyGADT x -> x
 
 
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index ee304073..6df9062e 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -243,7 +243,7 @@ ppDocGroup lev doc = sec lev <> braces doc
 
 declNames :: LHsDecl DocName -> [DocName]
 declNames (L _ decl) = case decl of
-  TyClD d  -> [unLoc $ tcdLName d]
+  TyClD d  -> [tcdName d]
   SigD (TypeSig lnames _) -> map unLoc lnames
   _ -> error "declaration not supported by declNames"
 
@@ -275,10 +275,10 @@ ppDecl :: LHsDecl DocName
        -> LaTeX
 
 ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of
-  TyClD d@(TyFamily {})          -> ppTyFam False loc doc d unicode
-  TyClD d@(TyDecl{ tcdTyDefn = defn })   
-      | isHsDataDefn defn        -> ppDataDecl instances subdocs loc doc d unicode
-      | otherwise                -> ppTySyn loc (doc, fnArgsDoc) d unicode
+  TyClD d@(FamDecl {})          -> ppTyFam False loc doc d unicode
+  TyClD d@(DataDecl {})   
+                                -> ppDataDecl instances subdocs loc doc d unicode
+  TyClD d@(SynDecl {})          -> ppTySyn loc (doc, fnArgsDoc) d unicode
 -- Family instances happen via FamInst now
 --  TyClD d@(TySynonym {})         
 --    | Just _  <- tcdTyPats d    -> ppTyInst False loc doc d unicode
@@ -311,8 +311,8 @@ ppFor _ _ _ _ =
 -- we skip type patterns for now
 ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX
 
-ppTySyn loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars
-                        , tcdTyDefn = TySynonym { td_synRhs = ltype } }) unicode
+ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
+                         , tcdRhs = ltype }) unicode
   = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode
   where
     hdr  = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars)
@@ -549,7 +549,7 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
    $$ instancesBit
 
   where
-    cons      = td_cons (tcdTyDefn dataDecl)
+    cons      = dd_cons (tcdDataDefn dataDecl)
     resTy     = (con_res . unLoc . head) cons
 
     body = catMaybes [constrBit, documentationToLaTeX doc]
@@ -694,8 +694,8 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
 -- | Print the LHS of a data\/newtype declaration.
 -- Currently doesn't handle 'data instance' decls or kind signatures
 ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX
-ppDataHeader (TyDecl { tcdLName = L _ name, tcdTyVars = tyvars
-                     , tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } }) unicode
+ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars
+                       , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode
   = -- newtype or data
     (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>
     -- context
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index c68b7cbc..3251477a 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -556,10 +556,10 @@ processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName
 processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts) =
   ((divTopDecl <<).(declElem <<)) `fmap` case decl0 of
     TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
-        (TyFamily{}) -> [ppTyFamHeader True False d unicode qual]
-        (TyDecl{ tcdTyDefn = TyData {} }) -> [keyword "data" <+> b]
-        (TyDecl{ tcdTyDefn = TySynonym {} }) -> [keyword "type" <+> b]
-        (ClassDecl {})    -> [keyword "class" <+> b]
+        (FamDecl decl)    -> [ppTyFamHeader True False decl unicode qual]
+        (DataDecl{})   -> [keyword "data" <+> b]
+        (SynDecl{})    -> [keyword "type" <+> b]
+        (ClassDecl {}) -> [keyword "class" <+> b]
         _ -> []
     SigD (TypeSig lnames (L _ _)) ->
       map (ppNameMini mdl . nameOccName . getName . unLoc) lnames
@@ -578,8 +578,8 @@ ppNameMini mdl nm =
 
 ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html
 ppTyClBinderWithVarsMini mdl decl =
-  let n = unLoc $ tcdLName decl
-      ns = tyvarNames $ tcdTyVars decl
+  let n = tcdName decl
+      ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above
   in ppTypeApp n ns (ppNameMini mdl . nameOccName . getName) ppTyName
 
 
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 59be34f7..db39ccca 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -39,10 +39,9 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
           DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] ->
           Bool -> Qualification -> Html
 ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of
-  TyClD d@(TyFamily {})          -> ppTyFam summ False links loc mbDoc d unicode qual
-  TyClD d@(TyDecl{ tcdTyDefn = defn })   
-      | isHsDataDefn defn        -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
-      | otherwise                -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
+  TyClD (FamDecl d)              -> ppTyFam summ False links loc mbDoc d unicode qual
+  TyClD d@(DataDecl {})          -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
+  TyClD d@(SynDecl {})           -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
   TyClD d@(ClassDecl {})         -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual
   SigD (TypeSig lnames (L _ t))  -> ppFunSig summ links loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode qual
   ForD d                         -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual
@@ -115,8 +114,8 @@ ppFor _ _ _ _ _ _ _ = error "ppFor"
 -- we skip type patterns for now
 ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool
         -> Qualification -> Html
-ppTySyn summary links loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars
-                                      , tcdTyDefn = TySynonym { td_synRhs = ltype } }) 
+ppTySyn summary links loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
+                                       , tcdRhs = ltype }) 
         unicode qual
   = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
                    (full, hdr, spaceHtml +++ equals) unicode qual
@@ -145,10 +144,10 @@ ppTyName name
 --------------------------------------------------------------------------------
 
 
-ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
-ppTyFamHeader summary associated decl unicode qual =
-
-  (case tcdFlavour decl of
+ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName -> Bool -> Qualification -> Html
+ppTyFamHeader summary associated d@(FamilyDecl { fdFlavour = flav
+                                               , fdKindSig = mkind }) unicode qual =
+  (case flav of
      TypeFamily
        | associated -> keyword "type"
        | otherwise  -> keyword "type family"
@@ -157,22 +156,22 @@ ppTyFamHeader summary associated decl unicode qual =
        | otherwise  -> keyword "data family"
   ) <+>
 
-  ppTyClBinderWithVars summary decl <+>
+  ppFamDeclBinderWithVars summary d <+>
 
-  case tcdKindSig decl of
+  case mkind of
     Just kind -> dcolon unicode  <+> ppLKind unicode qual kind
     Nothing   -> noHtml
 
 
 ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName ->
-              TyClDecl DocName -> Bool -> Qualification -> Html
+              FamilyDecl DocName -> Bool -> Qualification -> Html
 ppTyFam summary associated links loc doc decl unicode qual
 
   | summary   = ppTyFamHeader True associated decl unicode qual
   | otherwise = header_ +++ docSection qual doc +++ instancesBit
 
   where
-    docname = tcdName decl
+    docname = unLoc $ fdLName decl
 
     header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode qual)
 
@@ -187,23 +186,25 @@ ppTyFam summary associated links loc doc decl unicode qual
 --------------------------------------------------------------------------------
 
 
-ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool
+ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName -> Bool
             -> Qualification -> Html
 ppAssocType summ links doc (L loc decl) unicode qual =
-  case decl of
-    TyFamily  {} -> ppTyFam summ True links loc (fst doc) decl unicode qual
-    _            -> error "declaration type not supported by ppAssocType"
+   ppTyFam summ True links loc (fst doc) decl unicode qual
 
 
 --------------------------------------------------------------------------------
 -- * TyClDecl helpers
 --------------------------------------------------------------------------------
 
+-- | Print a type family and its variables 
+ppFamDeclBinderWithVars :: Bool -> FamilyDecl DocName -> Html
+ppFamDeclBinderWithVars summ (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =
+  ppAppDocNameNames summ (unLoc lname) (tyvarNames tvs)
 
--- | Print a type family / newtype / data / class binder and its variables 
-ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> Html
-ppTyClBinderWithVars summ decl =
-  ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl)
+-- | Print a newtype / data binder and its variables 
+ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html
+ppDataBinderWithVars summ decl =
+  ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl)
 
 
 --------------------------------------------------------------------------------
@@ -303,7 +304,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
       +++ shortSubDecls
           (
             [ ppAssocType summary links doc at unicode qual | at <- ats
-              , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]  ++
+              , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ]  ++
 
                 -- ToDo: add associated type defaults
 
@@ -336,14 +337,14 @@ ppClassDecl summary links instances loc d subdocs
       | null lsigs = topDeclElem links loc [nm] (hdr unicode qual)
       | otherwise  = topDeclElem links loc [nm] (hdr unicode qual <+> keyword "where")
 
-    nm   = unLoc $ tcdLName decl
+    nm   = tcdName decl
 
     hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
 
     -- ToDo: add assocatied typ defaults
     atBit = subAssociatedTypes [ ppAssocType summary links doc at unicode qual
                       | at <- ats
-                      , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]
+                      , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ]
 
     methodBit = subMethods [ ppFunSig summary links loc doc names typ unicode qual
                            | L _ (TypeSig lnames (L _ typ)) <- lsigs
@@ -401,7 +402,7 @@ ppShortDataDecl summary _links _loc dataDecl unicode qual
     doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual
     doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual
 
-    cons      = td_cons (tcdTyDefn dataDecl)
+    cons      = dd_cons (tcdDataDefn dataDecl)
     resTy     = (con_res . unLoc . head) cons
 
 
@@ -415,8 +416,8 @@ ppDataDecl summary links instances subdocs loc doc dataDecl unicode qual
   | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit
 
   where
-    docname   = unLoc . tcdLName $ dataDecl
-    cons      = td_cons (tcdTyDefn dataDecl)
+    docname   = tcdName dataDecl
+    cons      = dd_cons (tcdDataDefn dataDecl)
     resTy     = (con_res . unLoc . head) cons
 
     header_ = topDeclElem links loc [docname] (ppDataHeader summary dataDecl unicode qual
@@ -570,14 +571,15 @@ ppShortField summary unicode qual (ConDeclField (L _ name) ltype _)
 -- | Print the LHS of a data\/newtype declaration.
 -- Currently doesn't handle 'data instance' decls or kind signatures
 ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
-ppDataHeader summary decl@(TyDecl { tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } }) 
+ppDataHeader summary decl@(DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd
+                                                               , dd_ctxt = ctxt } }) 
              unicode qual
   = -- newtype or data
     (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>
     -- context
     ppLContext ctxt unicode qual <+>
     -- T a b c ..., or a :+: b
-    ppTyClBinderWithVars summary decl
+    ppDataBinderWithVars summary decl
 ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"