|
|
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Backends.HaddockDB
-- Copyright : (c) Simon Marlow 2003
-- License : BSD-like
--
-- Maintainer : haddock@projects.haskell.org
-- Stability : experimental
-- Portability : portable
-----------------------------------------------------------------------------
module Haddock.Backends.HaddockDB (ppDocBook) where
{-
import HaddockTypes
import HaddockUtil
import HsSyn2
import Text.PrettyPrint
-}
-----------------------------------------------------------------------------
-- Printing the results in DocBook format
ppDocBook :: a
ppDocBook = error "not working"
{-
ppDocBook :: FilePath -> [(Module, Interface)] -> String
ppDocBook odir mods = render (ppIfaces mods)
ppIfaces mods
= text "<!DOCTYPE BOOK PUBLIC \"-//OASIS//DTD DocBook V3.1//EN\" ["
$$ text "]>"
$$ text "<book>"
$$ text "<bookinfo>"
$$ text "<author><othername>HaskellDoc version 0.0</othername></author>"
$$ text "</bookinfo>"
$$ text "<article>"
$$ vcat (map do_mod mods)
$$ text "</article></book>"
where
do_mod (Module mod, iface)
= text "<sect1 id=\"sec-" <> text mod <> text "\">"
$$ text "<title><literal>"
<> text mod
<> text "</literal></title>"
$$ text "<indexterm><primary><literal>"
<> text mod
<> text "</literal></primary></indexterm>"
$$ text "<variablelist>"
$$ vcat (map (do_export mod) (eltsFM (iface_decls iface)))
$$ text "</variablelist>"
$$ text "</sect1>"
do_export mod decl | (nm:_) <- declBinders decl
= text "<varlistentry id=" <> ppLinkId mod nm <> char '>'
$$ text "<term><literal>"
<> do_decl decl
<> text "</literal></term>"
$$ text "<listitem>"
$$ text "<para>"
$$ text "</para>"
$$ text "</listitem>"
$$ text "</varlistentry>"
do_export _ _ = empty
do_decl (HsTypeSig _ [nm] ty _)
= ppHsName nm <> text " :: " <> ppHsType ty
do_decl (HsTypeDecl _ nm args ty _)
= hsep ([text "type", ppHsName nm ]
++ map ppHsName args
++ [equals, ppHsType ty])
do_decl (HsNewTypeDecl loc ctx nm args con drv _)
= hsep ([text "data", ppHsName nm] -- data, not newtype
++ map ppHsName args
) <+> equals <+> ppHsConstr con -- ToDo: derivings
do_decl (HsDataDecl loc ctx nm args cons drv _)
= hsep ([text "data", {-ToDo: context-}ppHsName nm]
++ map ppHsName args)
<+> vcat (zipWith (<+>) (equals : repeat (char '|'))
(map ppHsConstr cons))
do_decl (HsClassDecl loc ty fds decl _)
= hsep [text "class", ppHsType ty]
do_decl decl
= empty
ppHsConstr :: HsConDecl -> Doc
ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) =
ppHsName name
<> (braces . hsep . punctuate comma . map ppField $ fieldList)
ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) =
hsep (ppHsName name : map ppHsBangType typeList)
ppField (HsFieldDecl ns ty doc)
= hsep (punctuate comma (map ppHsName ns) ++
[text "::", ppHsBangType ty])
ppHsBangType :: HsBangType -> Doc
ppHsBangType (HsBangedTy ty) = char '!' <> ppHsType ty
ppHsBangType (HsUnBangedTy ty) = ppHsType ty
ppHsContext :: HsContext -> Doc
ppHsContext [] = empty
ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+>
hsep (map ppHsAType b)) context)
ppHsType :: HsType -> Doc
ppHsType (HsForAllType _ Nothing context htype) =
hsep [ ppHsContext context, text "=>", ppHsType htype]
ppHsType (HsForAllType fvf (Just tvs) [] htype) =
hsep (text "forall" : map ppHsName tvs ++ pprHsForAllSeparator fvf :
[ppHsType htype])
ppHsType (HsForAllType fvf (Just tvs) context htype) =
hsep (text "forall" : map ppHsName tvs ++ pprHsForAllSeparator fvf :
ppHsContext context : text "=>" : [ppHsType htype])
ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b]
ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t]
ppHsType t = ppHsBType t
ppHsForAllSeparator :: ForallVisFlag -> Doc
ppHsForAllSeparator ForallVis = text "->"
ppHsForAllSeparator ForallInvis = text "."
ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
= brackets $ ppHsType b
ppHsBType (HsTyApp a b) = fsep [ppHsBType a, ppHsAType b]
ppHsBType t = ppHsAType t
ppHsAType :: HsType -> Doc
ppHsAType (HsTyTuple True l) = parenList . map ppHsType $ l
ppHsAType (HsTyTuple False l) = ubxParenList . map ppHsType $ l
-- special case
ppHsAType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
= brackets $ ppHsType b
ppHsAType (HsTyVar name) = ppHsName name
ppHsAType (HsTyCon name) = ppHsQName name
ppHsAType t = parens $ ppHsType t
ppHsQName :: HsQName -> Doc
ppHsQName (UnQual str) = ppHsName str
ppHsQName n@(Qual (Module mod) str)
| n == unit_con_name = ppHsName str
| isSpecial str = ppHsName str
| otherwise
= text "<link linkend=" <> ppLinkId mod str <> char '>'
<> ppHsName str
<> text "</link>"
isSpecial (HsTyClsName id) | HsSpecial _ <- id = True
isSpecial (HsVarName id) | HsSpecial _ <- id = True
isSpecial _ = False
ppHsName :: HsName -> Doc
ppHsName (HsTyClsName id) = ppHsIdentifier id
ppHsName (HsVarName id) = ppHsIdentifier id
ppHsIdentifier :: HsIdentifier -> Doc
ppHsIdentifier (HsIdent str) = text str
ppHsIdentifier (HsSymbol str) = text str
ppHsIdentifier (HsSpecial str) = text str
ppLinkId :: String -> HsName -> Doc
ppLinkId mod str
= hcat [char '\"', text mod, char '.', ppHsName str, char '\"']
-- -----------------------------------------------------------------------------
-- * Misc
parenList :: [Doc] -> Doc
parenList = parens . fsep . punctuate comma
ubxParenList :: [Doc] -> Doc
ubxParenList = ubxparens . fsep . punctuate comma
ubxparens p = text "(#" <> p <> text "#)"
-}
|