blob: 91f4225d7b708457b351522e0cc924ce0e0402e3 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
--
-- Haddock - A Haskell Documentation Tool
--
-- (c) Simon Marlow 2003
--
-- This file, (c) Neil Mitchell 2006-2008
-- Write out Hoogle compatible documentation
-- http://www.haskell.org/hoogle/
module Haddock.Backends.Hoogle (
ppHoogle
) where
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 = (fromMaybe "hoogle" maybe_package) <.> "txt"
contents = prefix ++ concat [ppModule i | i <- ifaces, OptHide `notElem` ifaceOptions i]
writeFile (odir </> filename) (unlines contents)
ppModule :: Interface -> [String]
ppModule iface = ["", "module " ++ moduleString (ifaceMod iface)] ++
concatMap ppExport (ifaceExportItems iface) ++
concatMap ppInstance (ifaceInstances iface)
---------------------------------------------------------------------
-- Utility functions
indent = (++) " "
unL (L _ x) = x
dropComment (' ':'-':'-':' ':_) = []
dropComment (x:xs) = x : dropComment xs
dropComment [] = []
out :: Outputable a => a -> String
out = unwords . map (dropWhile isSpace) . lines . showSDocUnqual . ppr
typeSig :: String -> [String] -> String
typeSig name flds = name ++ " :: " ++ concat (intersperse " -> " flds)
---------------------------------------------------------------------
-- How to print each export
ppExport :: ExportItem Name -> [String]
ppExport (ExportDecl name decl _ _) = f $ unL decl
where
f (TyClD d@TyData{}) = ppData d
f (TyClD d@ClassDecl{}) = ppClass d
f decl = [out decl]
ppExport _ = []
ppClass :: TyClDecl Name -> [String]
ppClass x = out x{tcdSigs=[]} :
map (indent . out) (tcdSigs x)
ppInstance :: Instance -> [String]
ppInstance x = [dropComment $ out x]
ppData :: TyClDecl Name -> [String]
ppData x = showData x{tcdCons=[],tcdDerivs=Nothing} :
concatMap (ppCtor x . unL) (tcdCons x)
where
showData = unwords . f . words . out
-- 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
ppCtor :: TyClDecl Name -> ConDecl Name -> [String]
ppCtor dat con = f $ con_details con
where
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
|
