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
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
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 _ = []
|
