aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Backends
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2012-03-26 09:14:23 +0100
committerSimon Peyton Jones <simonpj@microsoft.com>2012-03-26 09:14:23 +0100
commit1e6e6c01babee971420e1876cdffdfb0bf673c1e (patch)
tree892a4b3be7d2bd68ddb3bc50543a1e2834590092 /src/Haddock/Backends
parent730d3e622268f59fd78d29026d164486c4e68fcb (diff)
Follow refactoring of TyClDecl/HsTyDefn
Diffstat (limited to 'src/Haddock/Backends')
-rw-r--r--src/Haddock/Backends/Hoogle.hs19
-rw-r--r--src/Haddock/Backends/LaTeX.hs56
-rw-r--r--src/Haddock/Backends/Xhtml.hs8
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs78
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"
--------------------------------------------------------------------------------