[haddock @ 2002-04-04 16:23:43 by simonmar]

This is Haddock, my stab at a Haskell documentation tool.  It's not
quite ready for release yet, but I'm putting it in the repository so
others can take a look.

It uses a locally modified version of the hssource parser, extended
with support for GHC extensions and documentation annotations.

1 files changed, 158 insertions, 0 deletions

diff --git a/src/HaddockDB.hs b/src/HaddockDB.hs
new file mode 100644
index 00000000..1edd90fd
--- /dev/null
+++ b/src/HaddockDB.hs
@@ -0,0 +1,158 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2002
+--
+
+module HaddockDB (ppDocBook) where
+
+import HaddockTypes hiding (Doc)
+import HsSyn
+import Pretty
+import FiniteMap
+
+-----------------------------------------------------------------------------
+-- Printing the results in DocBook format
+
+ppDocBook :: [(Module, Interface)] -> String
+ppDocBook 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 decl)
+	= hsep [text "class", ppHsType ty]
+     do_decl decl
+	= empty
+
+ppHsConstr :: HsConDecl -> Doc
+ppHsConstr (HsRecDecl pos name fieldList maybe_doc) =
+	 ppHsName name
+	 <> (braces . hsep . punctuate comma . map ppField $ fieldList)
+ppHsConstr (HsConDecl pos name 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 (Just tvs) [] htype) =
+     hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype])
+ppHsType (HsForAllType (Just tvs) context htype) =
+     hsep (text "forall" : map ppHsName tvs ++ text "." : 
+	   ppHsContext context : text "=>" : [ppHsType htype])
+ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "-&gt;", ppHsType b]
+ppHsType t = ppHsBType t
+
+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 "#)"