aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Backends/Hoogle.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Backends/Hoogle.hs')
-rw-r--r--src/Haddock/Backends/Hoogle.hs199
1 files changed, 62 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
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 23:01:39 +0000