diff --git a/src/HaddockHoogle.hs b/src/HaddockHoogle.hs
new file mode 100644
index 0000000000000000000000000000000000000000..a846f58ca01db5478177c6953296a848f27ca425
--- /dev/null
+++ b/src/HaddockHoogle.hs
@@ -0,0 +1,180 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+-- This file, (c) Neil Mitchell 2006
+-- Write out Hoogle compatible documentation
+-- http://www.haskell.org/hoogle/
+
+module HaddockHoogle (
+ ppHoogle
+ ) where
+
+import HaddockTypes
+import HaddockUtil
+import HsSyn
+
+import Data.List ( intersperse )
+
+
+
+prefix = ["-- Hoogle documentation, generated by Haddock",
+ "-- See Hoogle, http://www.haskell.org/hoogle/"]
+
+ppHoogle :: Maybe String -> [Interface] -> FilePath -> IO ()
+ppHoogle maybe_package ifaces odir =
+ do
+ let
+ filename = case maybe_package of
+ Just x -> x ++ ".txt"
+ Nothing -> "hoogle.txt"
+
+ visible_ifaces = filter visible ifaces
+ visible i = OptHide `notElem` iface_options i
+
+ contents = prefix : map ppModule visible_ifaces
+
+ writeFile (pathJoin [odir, filename]) (unlines $ concat contents)
+
+
+
+-- ---------------------------------------------------------------------------
+-- Generate the HTML page for a module
+
+
+ppDecl :: HsDecl -> [String]
+ppDecl (HsNewTypeDecl src context name args ctor unknown docs) =
+ ppData "newtype" context name args [ctor]
+
+ppDecl (HsDataDecl src context name args ctors unknown docs) =
+ ppData "data" context name args ctors
+
+ppDecl (HsTypeSig src names t doc) = map (`ppFunc` t) names
+
+ppDecl (HsForeignImport src _ _ _ name t doc) = ppDecl $ HsTypeSig src [name] t doc
+
+ppDecl (HsClassDecl src context name args fundeps members doc) =
+ ("class " ++ ppContext context ++ ppType typ) : concatMap f members
+ where
+ typ = foldl HsTyApp (HsTyCon $ UnQual name) (map HsTyVar args)
+ newcontext = (UnQual name, map HsTyVar args)
+ f (HsTypeSig src names t doc) = ppDecl (HsTypeSig src names (addContext newcontext t) doc)
+ f (HsFunBind{}) = []
+ f (HsPatBind{}) = []
+ f x = ["-- ERR " ++ show x]
+
+ppDecl (HsTypeDecl src name args t doc) =
+ ["type " ++ show name ++ concatMap (\x -> ' ':show x) args ++ " = " ++ ppType t]
+
+ppDecl x = ["-- ERR " ++ show x]
+
+
+
+addContext :: HsAsst -> HsType -> HsType
+addContext ctx (HsForAllType Nothing context t) = HsForAllType Nothing (HsAssump ctx : context) t
+addContext ctx x = HsForAllType Nothing [HsAssump ctx] x
+
+
+
+ppFunc :: HsName -> HsType -> String
+ppFunc name typ = show name ++ " :: " ++ ppType typ
+
+
+ppData :: String -> HsContext -> HsName -> [HsName] -> [HsConDecl] -> [String]
+ppData mode context name args ctors = (mode ++ " " ++ ppType typ) : concatMap (ppCtor typ) ctors
+ where
+ typ = foldl HsTyApp (HsTyCon $ UnQual name) (map HsTyVar args)
+
+
+deBang :: HsBangType -> HsType
+deBang (HsBangedTy x) = x
+deBang (HsUnBangedTy x) = x
+
+
+ppCtor :: HsType -> HsConDecl -> [String]
+ppCtor result (HsConDecl src name types context typ doc) =
+ [show name ++ " :: " ++ ppContext context ++ ppTypesArr (map deBang typ ++ [result])]
+
+ppCtor result (HsRecDecl src name types context fields doc) =
+ ppCtor result (HsConDecl src name types context (map snd fields2) doc) ++
+ concatMap f fields2
+ where
+ fields2 = [(name, typ) | HsFieldDecl names typ _ <- fields, name <- names]
+ f (name, typ) = ppDecl $ HsTypeSig src [name] (HsTyFun result (deBang typ)) doc
+
+
+brack True x = "(" ++ x ++ ")"
+brack False x = x
+
+ppContext :: HsContext -> String
+ppContext [] = ""
+ppContext xs = brack (length xs > 1) (concat $ intersperse ", " $ map ppContextItem xs) ++ " => "
+
+ppContextItem :: HsAsst -> String
+ppContextItem (name, types) = ppQName name ++ concatMap (\x -> ' ':ppType x) types
+
+ppContext2 :: HsIPContext -> String
+ppContext2 xs = ppContext [x | HsAssump x <- xs]
+
+
+ppType :: HsType -> String
+ppType x = f 0 x
+ where
+ f _ (HsTyTuple _ xs) = brack True $ concat $ intersperse ", " $ map (f 0) xs
+ f _ (HsTyCon x) = ppQName x
+ f _ (HsTyVar x) = show x
+
+ -- ignore ForAll types as Hoogle does not support them
+ f n (HsForAllType (Just items) context t) =
+ -- brack (n > 1) $
+ -- "forall" ++ concatMap (\x -> ' ':toStr x) items ++ " . " ++ f 0 t
+ f n t
+
+ f n (HsForAllType Nothing context t) = brack (n > 1) $
+ ppContext2 context ++ f 0 t
+
+ f n (HsTyFun a b) = brack g $ f (h 3) a ++ " -> " ++ f (h 2) b
+ where
+ g = n > 2
+ h x = if g then 0 else x
+
+ f n (HsTyApp a b) | ppType a == "[]" = "[" ++ f 0 b ++ "]"
+
+ f n (HsTyApp a b) = brack g $ f (h 3) a ++ " " ++ f (h 4) b
+ where
+ g = n > 3
+ h x = if g then 0 else x
+
+ f n (HsTyDoc x _) = f n x
+
+ f n x = brack True $ show x
+
+
+ppQName :: HsQName -> String
+ppQName (Qual _ name) = show name
+ppQName (UnQual name) = show name
+
+
+
+ppTypesArr :: [HsType] -> String
+ppTypesArr xs = ppType $ foldr1 HsTyFun xs
+
+
+
+ppInst :: InstHead -> String
+ppInst (context, item) = "instance " ++ ppContext context ++ ppContextItem item
+
+
+
+ppModule :: Interface -> [String]
+ppModule iface = "" : ("module " ++ mdl) : concatMap ppExport (iface_exports iface)
+ where
+ Module mdl = iface_module iface
+
+
+ppExport :: ExportItem -> [String]
+ppExport (ExportDecl name decl insts) = ppDecl decl ++ map ppInst insts
+ppExport _ = []
+
+
diff --git a/src/Main.hs b/src/Main.hs
index 7001d88af43b691f2373d27fd401867f4a8a50d1..e9ffb6044db2c35c635fa5d38f8c48eff43e4b95 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -11,6 +11,7 @@ import Binary
import Digraph
--import HaddockDB -- not compiling
import HaddockHtml
+import HaddockHoogle
import HaddockLex
import HaddockParse
import HaddockRename
@@ -72,6 +73,7 @@ data Flag
| Flag_Heading String
| Flag_Package String
| Flag_Html
+ | Flag_Hoogle
| Flag_HtmlHelp String
| Flag_Lib String
| Flag_NoImplicitPrelude
@@ -111,6 +113,8 @@ options backwardsCompat =
-- "output in DocBook XML",
Option ['h'] ["html"] (NoArg Flag_Html)
"output in HTML",
+ Option [] ["hoogle"] (NoArg Flag_Hoogle)
+ "output for Hoogle",
Option [] ["html-help"] (ReqArg Flag_HtmlHelp "format")
"produce index and table of contents in\nmshelp, mshelp2 or devhelp format (with -h)",
Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL")
@@ -320,6 +324,9 @@ run flags files = do
maybe_contents_url maybe_index_url
copyHtmlBits odir libdir css_file
+ when (Flag_Hoogle `elem` flags) $ do
+ ppHoogle package these_ifaces odir
+
-- dump an interface if requested
case dump_iface of
Nothing -> return ()