diff options
| -rw-r--r-- | src/HaddockHoogle.hs | 180 | ||||
| -rw-r--r-- | src/Main.hs | 7 |
2 files changed, 187 insertions, 0 deletions
diff --git a/src/HaddockHoogle.hs b/src/HaddockHoogle.hs new file mode 100644 index 00000000..a846f58c --- /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 7001d88a..e9ffb604 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 () |