Follow refactoring of TyClDecl/HsTyDefn

4 files changed, 48 insertions, 113 deletions

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 593f03bc..c0569006 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -111,9 +111,10 @@ operator x = x
 ppExport :: ExportItem Name -> [String]
 ppExport (ExportDecl decl dc subdocs _) = doc (fst dc) ++ f (unL decl)
     where
-        f (TyClD d@TyData{}) = ppData d subdocs
+        f (TyClD d@TyDecl{})
+            | isDataDecl d      = ppData d subdocs
+            | otherwise         = ppSynonym d
         f (TyClD d@ClassDecl{}) = ppClass d
-        f (TyClD d@TySynonym{}) = ppSynonym d
         f (ForD (ForeignImport name typ _ _)) = ppSig $ TypeSig [name] typ
         f (ForD (ForeignExport name typ _ _)) = ppSig $ TypeSig [name] typ
         f (SigD sig) = ppSig sig
@@ -131,10 +132,6 @@ ppSig (TypeSig names sig) = [operator prettyNames ++ " :: " ++ outHsType typ]
 ppSig _ = []
 
 
-ppSynonym :: TyClDecl Name -> [String]
-ppSynonym x = [out x]
-
-
 -- note: does not yet output documentation for class methods
 ppClass :: TyClDecl Name -> [String]
 ppClass x = out x{tcdSigs=[]} :
@@ -154,10 +151,15 @@ ppInstance :: ClsInst -> [String]
 ppInstance x = [dropComment $ out x]
 
 
+ppSynonym :: TyClDecl Name -> [String]
+ppSynonym x = [out x]
+
 ppData :: TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
-ppData x subdocs = showData x{tcdCons=[],tcdDerivs=Nothing} :
-                   concatMap (ppCtor x subdocs . unL) (tcdCons x)
+ppData decl@(TyDecl { tcdTyDefn = defn }) subdocs
+    = showData decl{ tcdTyDefn = defn { td_cons=[],td_derivs=Nothing }} :
+      concatMap (ppCtor decl subdocs . unL) (td_cons defn)
     where
+        
         -- GHC gives out "data Bar =", we want to delete the equals
         -- also writes data : a b, when we want data (:) a b
         showData d = unwords $ map f $ if last xs == "=" then init xs else xs
@@ -165,6 +167,7 @@ ppData x subdocs = showData x{tcdCons=[],tcdDerivs=Nothing} :
                 xs = words $ out d
                 nam = out $ tcdLName d
                 f w = if w == nam then operator nam else w
+ppData _ _ = panic "ppData"
 
 -- | for constructors, and named-fields...
 lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> Maybe (Doc Name)
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index deb224a8..c3a8faa0 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -278,12 +278,14 @@ ppDecl :: LHsDecl DocName
 
 ppDecl (L loc decl) (mbDoc, fnArgsDoc) instances subdocs = case decl of
   TyClD d@(TyFamily {})          -> ppTyFam False loc mbDoc d unicode
-  TyClD d@(TyData {})
-    | Nothing <- tcdTyPats d     -> ppDataDecl instances subdocs loc mbDoc d unicode
-    | Just _  <- tcdTyPats d     -> ppDataInst loc mbDoc d
-  TyClD d@(TySynonym {})
-    | Nothing <- tcdTyPats d     -> ppTySyn loc (mbDoc, fnArgsDoc) d unicode
-    | Just _  <- tcdTyPats d     -> ppTyInst False loc mbDoc d unicode
+  TyClD d@(TyDecl{ tcdTyDefn = defn })   
+      | isHsDataDefn defn        -> ppDataDecl instances subdocs loc mbDoc d unicode
+      | otherwise                -> ppTySyn loc (mbDoc, fnArgsDoc) d unicode
+--    | Just _  <- tcdTyPats d     -> ppDataInst loc mbDoc d
+-- Family instances happen via FamInst now
+--  TyClD d@(TySynonym {})         
+--    | Just _  <- tcdTyPats d    -> ppTyInst False loc mbDoc d unicode
+-- Family instances happen via FamInst now
   TyClD d@(ClassDecl {})         -> ppClassDecl instances loc mbDoc subdocs d unicode
   SigD (TypeSig lnames (L _ t))  -> ppFunSig loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode
   ForD d                         -> ppFor loc (mbDoc, fnArgsDoc) d unicode
@@ -299,17 +301,6 @@ ppTyFam _ _ _ _ _ =
   error "type family declarations are currently not supported by --latex"
 
 
-ppDataInst :: a
-ppDataInst =
-  error "data instance declarations are currently not supported by --latex"
-
-
-ppTyInst :: Bool -> SrcSpan -> Maybe (Doc DocName) ->
-            TyClDecl DocName -> Bool -> LaTeX
-ppTyInst _ _ _ _ _ =
-  error "type instance declarations are currently not supported by --latex"
-
-
 ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX
 ppFor _ _ _ _ =
   error "foreign declarations are currently not supported by --latex"
@@ -323,7 +314,8 @@ ppFor _ _ _ _ =
 -- we skip type patterns for now
 ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX
 
-ppTySyn loc doc (TySynonym (L _ name) ltyvars _ ltype _) unicode
+ppTySyn loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars
+                        , tcdTyDefn = TySynonym { td_synRhs = ltype } }) unicode
   = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode
   where
     hdr  = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars)
@@ -559,7 +551,7 @@ ppDataDecl instances subdocs _loc mbDoc dataDecl unicode
    $$ instancesBit
 
   where
-    cons      = tcdCons dataDecl
+    cons      = td_cons (tcdTyDefn dataDecl)
     resTy     = (con_res . unLoc . head) cons
 
     body = catMaybes [constrBit, fmap docToLaTeX mbDoc]
@@ -705,27 +697,15 @@ 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 decl unicode
-  | not (isDataDecl decl) = error "ppDataHeader: illegal argument"
-  | otherwise =
-    -- newtype or data
-    (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+>
+ppDataHeader (TyDecl { tcdLName = L _ name, tcdTyVars = tyvars
+                     , tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } }) unicode
+  = -- newtype or data
+    (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>
     -- context
-    ppLContext (tcdCtxt decl) unicode <+>
+    ppLContext ctxt unicode <+>
     -- T a b c ..., or a :+: b
-    ppTyClBinderWithVars False decl
-
-
---------------------------------------------------------------------------------
--- * TyClDecl helpers
---------------------------------------------------------------------------------
-
-
--- | Print a type family / newtype / data / class binder and its variables 
-ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> LaTeX
-ppTyClBinderWithVars summ decl =
-  ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl)
-
+    ppAppDocNameNames False name (tyvarNames tyvars)
+ppDataHeader _ _ = error "ppDataHeader: illegal argument"
 
 --------------------------------------------------------------------------------
 -- * Type applications
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 52bde5b6..50aad789 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -562,12 +562,8 @@ 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]
-        (TyData{tcdTyPats = ps})
-          | Nothing <- ps -> [keyword "data" <+> b]
-          | Just _ <- ps  -> [keyword "data" <+> keyword "instance" <+> b]
-        (TySynonym{tcdTyPats = ps})
-          | Nothing <- ps -> [keyword "type" <+> b]
-          | Just _ <- ps  -> [keyword "type" <+> keyword "instance" <+> b]
+        (TyDecl{ tcdTyDefn = TyData {} }) -> [keyword "data" <+> b]
+        (TyDecl{ tcdTyDefn = TySynonym {} }) -> [keyword "type" <+> b]
         (ClassDecl {})    -> [keyword "class" <+> b]
         _ -> []
     SigD (TypeSig lnames (L _ _)) ->
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 28955c22..ee0223c2 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -29,7 +29,6 @@ import Haddock.Types
 import           Control.Monad         ( join )
 import           Data.List             ( intersperse )
 import qualified Data.Map as Map
-import           Data.Maybe
 import           Text.XHtml hiding     ( name, title, p, quote )
 
 import GHC
@@ -43,12 +42,9 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl 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@(TyData {})
-    | Nothing <- tcdTyPats d     -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
-    | Just _  <- tcdTyPats d     -> ppDataInst summ links loc mbDoc d
-  TyClD d@(TySynonym {})
-    | Nothing <- tcdTyPats d     -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
-    | Just _  <- tcdTyPats d     -> ppTyInst 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 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
@@ -121,7 +117,9 @@ 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 (TySynonym (L _ name) ltyvars _ ltype _) unicode qual
+ppTySyn summary links loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars
+                                      , tcdTyDefn = TySynonym { td_synRhs = ltype } }) 
+        unicode qual
   = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
                    (full, hdr, spaceHtml +++ equals) unicode qual
   where
@@ -187,50 +185,6 @@ ppTyFam summary associated links loc mbDoc decl unicode qual
 
 
 --------------------------------------------------------------------------------
--- * Indexed data types
---------------------------------------------------------------------------------
-
-
-ppDataInst :: a
-ppDataInst = undefined
-
-
---------------------------------------------------------------------------------
--- * Indexed newtypes
---------------------------------------------------------------------------------
-
--- TODO
--- ppNewTyInst = undefined
-
-
---------------------------------------------------------------------------------
--- * Indexed types
---------------------------------------------------------------------------------
-
-
-ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) ->
-            TyClDecl DocName -> Bool -> Qualification -> Html
-ppTyInst summary associated links loc mbDoc decl unicode qual
-
-  | summary   = ppTyInstHeader True associated decl unicode qual
-  | otherwise = header_ +++ maybeDocSection qual mbDoc
-
-  where
-    docname = tcdName decl
-
-    header_ = topDeclElem links loc [docname]
-                (ppTyInstHeader summary associated decl unicode qual)
-
-
-ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
-ppTyInstHeader _ _ decl unicode qual =
-  keyword "type instance" <+>
-  ppAppNameTypes (tcdName decl) typeArgs unicode qual
-  where
-    typeArgs = map unLoc . fromJust . tcdTyPats $ decl
-
-
---------------------------------------------------------------------------------
 -- * Associated Types
 --------------------------------------------------------------------------------
 
@@ -240,7 +194,6 @@ ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> B
 ppAssocType summ links doc (L loc decl) unicode qual =
   case decl of
     TyFamily  {} -> ppTyFam summ True links loc (fst doc) decl unicode qual
-    TySynonym {} -> ppTySyn summ links loc doc decl unicode qual
     _            -> error "declaration type not supported by ppAssocType"
 
 
@@ -353,6 +306,8 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _ _) lo
             [ ppAssocType summary links doc at unicode qual | at <- ats
               , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]  ++
 
+                -- ToDo: add associated type defaults
+
             [ ppFunSig summary links loc doc names typ unicode qual
               | L _ (TypeSig lnames (L _ typ)) <- sigs
               , let doc = lookupAnySubdoc (head names) subdocs
@@ -385,6 +340,7 @@ ppClassDecl summary links instances loc mbDoc subdocs
 
     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 ]
@@ -448,7 +404,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      = tcdCons dataDecl
+    cons      = td_cons (tcdTyDefn dataDecl)
     resTy     = (con_res . unLoc . head) cons
 
 
@@ -463,7 +419,7 @@ ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode qual
 
   where
     docname   = unLoc . tcdLName $ dataDecl
-    cons      = tcdCons dataDecl
+    cons      = td_cons (tcdTyDefn dataDecl)
     resTy     = (con_res . unLoc . head) cons
 
     header_ = topDeclElem links loc [docname] (ppDataHeader summary dataDecl unicode qual
@@ -618,15 +574,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 unicode qual
-  | not (isDataDecl decl) = error "ppDataHeader: illegal argument"
-  | otherwise =
-    -- newtype or data
-    (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+>
+ppDataHeader summary decl@(TyDecl { tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } }) 
+             unicode qual
+  = -- newtype or data
+    (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>
     -- context
-    ppLContext (tcdCtxt decl) unicode qual <+>
+    ppLContext ctxt unicode qual <+>
     -- T a b c ..., or a :+: b
     ppTyClBinderWithVars summary decl
+ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"
 
 
 --------------------------------------------------------------------------------