-    Haddock.Backends.HaddockDB

------------------------------------------------------------------------------

-

------------------------------------------------------------------------------

-

--- |

--- 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 "#)"

--}