diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Haddock/Backends/Hoogle.hs | 199 | ||||
| -rw-r--r-- | src/Main.hs | 2 |
2 files changed, 64 insertions, 137 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index d93c055b..91f4225d 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -3,182 +3,107 @@ -- -- (c) Simon Marlow 2003 -- --- This file, (c) Neil Mitchell 2006 +-- This file, (c) Neil Mitchell 2006-2008 -- Write out Hoogle compatible documentation -- http://www.haskell.org/hoogle/ module Haddock.Backends.Hoogle ( - ppHoogle + ppHoogle ) where -ppHoogle = undefined -{- -import HaddockTypes -import HaddockUtil -import HsSyn2 - -import Data.List ( intersperse ) +import Haddock.Types +import Haddock.GHC +import GHC hiding ((<.>)) +import SrcLoc +import Outputable +import Data.Char +import Data.List +import Data.Maybe +import System.FilePath 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 +ppHoogle :: Maybe String -> [Interface] -> FilePath -> IO () +ppHoogle maybe_package ifaces odir = do + let filename = (fromMaybe "hoogle" maybe_package) <.> "txt" + contents = prefix ++ concat [ppModule i | i <- ifaces, OptHide `notElem` ifaceOptions i] + writeFile (odir </> filename) (unlines contents) -ppDecl (HsTypeSig src names t doc) = map (`ppFunc` t) names -ppDecl (HsForeignImport src _ _ _ name t doc) = ppDecl $ HsTypeSig src [name] t doc +ppModule :: Interface -> [String] +ppModule iface = ["", "module " ++ moduleString (ifaceMod iface)] ++ + concatMap ppExport (ifaceExportItems iface) ++ + concatMap ppInstance (ifaceInstances iface) -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] +--------------------------------------------------------------------- +-- Utility functions -ppDecl x = ["-- ERR " ++ show x] +indent = (++) " " +unL (L _ x) = x +dropComment (' ':'-':'-':' ':_) = [] +dropComment (x:xs) = x : dropComment xs +dropComment [] = [] -addContext :: HsAsst -> HsType -> HsType -addContext ctx (HsForAllType Nothing context t) = HsForAllType Nothing (HsAssump ctx : context) t -addContext ctx x = HsForAllType Nothing [HsAssump ctx] x +out :: Outputable a => a -> String +out = unwords . map (dropWhile isSpace) . lines . showSDocUnqual . ppr -ppFunc :: HsName -> HsType -> String -ppFunc name typ = show name ++ " :: " ++ ppType typ +typeSig :: String -> [String] -> String +typeSig name flds = name ++ " :: " ++ concat (intersperse " -> " flds) -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 - +--------------------------------------------------------------------- +-- How to print each export -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 +ppExport :: ExportItem Name -> [String] +ppExport (ExportDecl name decl _ _) = f $ unL decl where - fields2 = [(name, typ) | HsFieldDecl names typ _ <- fields, name <- names] - f (name, typ) = ppDecl $ HsTypeSig src [name] (HsTyFun result (deBang typ)) doc - + f (TyClD d@TyData{}) = ppData d + f (TyClD d@ClassDecl{}) = ppClass d + f decl = [out decl] +ppExport _ = [] -brack True x = "(" ++ x ++ ")" -brack False x = x -ppContext :: HsContext -> String -ppContext [] = "" -ppContext xs = brack (length xs > 1) (concat $ intersperse ", " $ map ppContextItem xs) ++ " => " +ppClass :: TyClDecl Name -> [String] +ppClass x = out x{tcdSigs=[]} : + map (indent . out) (tcdSigs x) -ppContextItem :: HsAsst -> String -ppContextItem (name, types) = ppQName name ++ concatMap (\x -> ' ':ppType x) types -ppContext2 :: HsIPContext -> String -ppContext2 xs = ppContext [x | HsAssump x <- xs] +ppInstance :: Instance -> [String] +ppInstance x = [dropComment $ out x] -ppType :: HsType -> String -ppType x = f 0 x +ppData :: TyClDecl Name -> [String] +ppData x = showData x{tcdCons=[],tcdDerivs=Nothing} : + concatMap (ppCtor x . unL) (tcdCons 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 + showData = unwords . f . words . out - 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 + -- note: tcdND always seems to not match NewType (BUG?) + f ("data":xs) | tcdND x == NewType = f ("newtype":xs) + f xs | ["="] `isSuffixOf` xs = init xs + f xs = xs - -ppInst :: InstHead -> String -ppInst (context, item) = "instance " ++ ppContext context ++ ppContextItem item - - - -ppModule :: Interface -> [String] -ppModule iface = "" : ("module " ++ mdl) : concatMap ppExport (iface_exports iface) +ppCtor :: TyClDecl Name -> ConDecl Name -> [String] +ppCtor dat con = f $ con_details con where - Module mdl = iface_module iface - - -ppExport :: ExportItem -> [String] -ppExport (ExportDecl name decl insts) = ppDecl decl ++ map ppInst insts -ppExport _ = [] + f (PrefixCon args) = [typeSig name $ map out args ++ [resType]] + f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] + f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ + [out (unL $ cd_fld_name r) `typeSig` [resType, out $ cd_fld_type r] | r <- recs] + name = out $ unL $ con_name con --} + resType = case con_res con of + ResTyH98 -> unwords $ out (tcdLName dat) : map out (tcdTyVars dat) + ResTyGADT x -> out $ unL x diff --git a/src/Main.hs b/src/Main.hs index e8f14654..a5381aff 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -227,6 +227,8 @@ render flags interfaces installedIfaces = do maybe_contents_url maybe_index_url copyHtmlBits odir libdir css_file + when (Flag_Hoogle `elem` flags) $ do + ppHoogle packageName visibleIfaces odir ------------------------------------------------------------------------------- -- Reading and dumping interface files |