-
Notifications
You must be signed in to change notification settings - Fork 134
/
Haddock.hs
207 lines (171 loc) · 9.06 KB
/
Haddock.hs
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
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
{-# LANGUAGE ViewPatterns, PatternGuards, TupleSections, OverloadedStrings, Rank2Types, DeriveDataTypeable #-}
module Input.Haddock(parseHoogle, fakePackage, input_haddock_test) where
import Language.Haskell.Exts as HSE
import Data.Char
import Data.List.Extra
import Data.Maybe
import Data.Data
import Input.Item
import General.Util
import Control.DeepSeq
import Control.Monad.Trans.Class
import General.Conduit
import Control.Monad.Extra
import Control.Exception.Extra
import Data.Generics.Uniplate.Data
import General.Str
import Safe
-- | An entry in the Hoogle DB
data Entry = EPackage PkgName
| EModule ModName
| EDecl (Decl ())
deriving (Data,Typeable,Show)
fakePackage :: PkgName -> String -> (Maybe Target, [Item])
fakePackage name desc = (Just $ Target (hackagePackageURL name) Nothing Nothing "package" (renderPackage name) desc, [IPackage name])
-- | Given a file name (for errors), feed in lines to the conduit and emit either errors or items
parseHoogle :: Monad m => (String -> m ()) -> URL -> LBStr -> ConduitM i (Maybe Target, [Item]) m ()
parseHoogle warning url body = sourceLStr body .| linesCR .| zipFromC 1 .| parserC warning .| hierarchyC url .| mapC (\x -> rnf x `seq` x)
parserC :: Monad m => (String -> m ()) -> ConduitM (Int, BStr) (Target, Entry) m ()
parserC warning = f [] ""
where
f com url = do
x <- await
whenJust x $ \(i,s) -> case () of
_ | Just s <- bstrStripPrefix "-- | " s -> f [ignoreMath s] url
| Just s <- bstrStripPrefix "--" s -> f (if null com then [] else bstrTrimStart s : com) url
| Just s <- bstrStripPrefix "@url " s -> f com (bstrUnpack s)
| bstrNull $ bstrTrimStart s -> f [] ""
| otherwise -> do
case parseLine $ fixLine $ bstrUnpack s of
Left y -> lift $ warning $ show i ++ ":" ++ y
-- only check Nothing as some items (e.g. "instance () :> Foo a")
-- don't roundtrip but do come out equivalent
Right [EDecl InfixDecl{}] -> pure () -- can ignore infix constructors
Right xs -> forM_ xs $ \x ->
yield (Target url Nothing Nothing (typeItem x) (renderItem x) $ reformat $ reverse com, x) -- descendBi stringShare x)
f [] ""
-- See https:/ndmitchell/hoogle/issues/353
-- for functions like `tail` which start <math>.
ignoreMath :: BStr -> BStr
ignoreMath x | Just x <- "<math>" `bstrStripPrefix` x
= fromMaybe x $ ". " `bstrStripPrefix` x
ignoreMath x = x
typeItem (EPackage x) = "package"
typeItem (EModule x) = "module"
typeItem _ = ""
-- FIXME: used to be in two different modules, now does and then undoes lots of stuff
reformat :: [BStr] -> String
reformat = unlines . map bstrUnpack
hierarchyC :: Monad m => URL -> ConduitM (Target, Entry) (Maybe Target, [Item]) m ()
hierarchyC packageUrl = void $ mapAccumC f (Nothing, Nothing)
where
f (pkg, mod) (t, EPackage x) = ((Just (strUnpack x, url), Nothing), (Just t{targetURL=url}, [IPackage x]))
where url = targetURL t `orIfNull` packageUrl
f (pkg, mod) (t, EModule x) = ((pkg, Just (strUnpack x, url)), (Just t{targetPackage=pkg, targetURL=url}, [IModule x]))
where url = targetURL t `orIfNull` (if isGhc then ghcModuleURL x else hackageModuleURL x)
f (pkg, mod) (t, EDecl i@InstDecl{}) = ((pkg, mod), (Nothing, hseToItem_ i))
f (pkg, mod) (t, EDecl x) = ((pkg, mod), (Just t{targetPackage=pkg, targetModule=mod, targetURL=url}, hseToItem_ x))
where url = targetURL t `orIfNull` case x of
_ | [n] <- declNames x -> hackageDeclURL (isTypeSig x) n
| otherwise -> ""
isGhc = "~ghc" `isInfixOf` packageUrl || "/" `isSuffixOf` packageUrl
hseToItem_ x = hseToItem x `orIfNull` error ("hseToItem failed, " ++ pretty x)
infix 1 `orIfNull`
orIfNull x y = if null x then y else x
renderPackage x = "<b>package</b> <span class=name><s0>" ++ escapeHTML (strUnpack x) ++ "</s0></span>"
renderModule (breakEnd (== '.') . strUnpack -> (pre,post)) = "<b>module</b> " ++ escapeHTML pre ++ "<span class=name><s0>" ++ escapeHTML post ++ "</s0></span>"
renderItem :: Entry -> String
renderItem = keyword . focus
where
keyword x | Just b <- stripPrefix "type family " x = "<b>type family</b> " ++ b
| (a,b) <- word1 x, a `elem` kws = "<b>" ++ a ++ "</b> " ++ b
| otherwise = x
where kws = words "class data type newtype"
name x = "<span class=name>" ++ x ++ "</span>" :: String
focus (EModule x) = renderModule x
focus (EPackage x) = renderPackage x
focus (EDecl x) | [now] <- declNames x, (pre,stripPrefix now -> Just post) <- breakOn now $ pretty x =
if "(" `isSuffixOf` pre && ")" `isPrefixOf` post then
init (escapeHTML pre) ++ name ("(" ++ highlight now ++ ")") ++ escapeHTML (tailErr post)
else
escapeHTML pre ++ name (highlight now) ++ escapeHTML post
focus (EDecl x) = pretty x
highlight :: String -> String
highlight x = "<s0>" ++ escapeHTML x ++ "</s0>"
parseLine :: String -> Either String [Entry]
parseLine x@('@':str) = case a of
"package" | [b] <- words b, b /= "" -> Right [EPackage $ strPack b]
"version" -> Right []
_ -> Left $ "unknown attribute: " ++ x
where (a,b) = word1 str
parseLine (stripPrefix "module " -> Just x) = Right [EModule $ strPack x]
parseLine x | Just x <- readItem x = case x of
TypeSig a bs c -> Right [EDecl (TypeSig a [b] c) | b <- bs]
x -> Right [EDecl x]
parseLine x = Left $ "failed to parse: " ++ x
fixLine :: String -> String
fixLine (stripPrefix "instance [incoherent] " -> Just x) = fixLine $ "instance " ++ x
fixLine (stripPrefix "instance [overlap ok] " -> Just x) = fixLine $ "instance " ++ x
fixLine (stripPrefix "instance [overlapping] " -> Just x) = fixLine $ "instance " ++ x
fixLine (stripPrefix "instance [safe] " -> Just x) = fixLine $ "instance " ++ x
fixLine (stripPrefix "(#) " -> Just x) = "( # ) " ++ x
fixLine ('[':x:xs) | isAlpha x || x `elem` ("_(" :: String), (a,']':b) <- break (== ']') xs = x : a ++ b
fixLine ('[':':':xs) | (a,']':b) <- break (== ']') xs = "(:" ++ a ++ ")" ++ b
fixLine x | "class " `isPrefixOf` x = fst $ breakOn " where " x
fixLine x = x
readItem :: String -> Maybe (Decl ())
readItem x | ParseOk y <- myParseDecl x = Just $ unGADT y
readItem x -- newtype
| Just x <- stripPrefix "newtype " x
, ParseOk (DataDecl an _ b c d e) <- fmap unGADT $ myParseDecl $ "data " ++ x
= Just $ DataDecl an (NewType ()) b c d e
readItem x -- constructors
| ParseOk (GDataDecl _ _ _ _ _ [GadtDecl s name _ _ _ ty] _) <- myParseDecl $ "data Data where " ++ x
, let f (TyBang _ _ _ (TyParen _ x@TyApp{})) = x
f (TyBang _ _ _ x) = x
f x = x
= Just $ TypeSig s [name] $ applyFun1 $ map f $ unapplyFun ty
readItem ('(':xs) -- tuple constructors
| (com,')':rest) <- span (== ',') xs
, ParseOk (TypeSig s [Ident{}] ty) <- myParseDecl $ replicate (length com + 2) 'a' ++ rest
= Just $ TypeSig s [Ident s $ '(':com++")"] ty
readItem (stripPrefix "data (" -> Just xs) -- tuple data type
| (com,')':rest) <- span (== ',') xs
, ParseOk (DataDecl a b c d e f) <- fmap unGADT $ myParseDecl $
"data " ++ replicate (length com + 2) 'A' ++ rest
= Just $ DataDecl a b c (transform (op $ '(':com++")") d) e f
where op s DHead{} = DHead () $ Ident () s
op s x = x
readItem _ = Nothing
myParseDecl = fmap (fmap $ const ()) . parseDeclWithMode parseMode -- partial application, to share the initialisation cost
unGADT (GDataDecl a b c d _ [] e) = DataDecl a b c d [] e
unGADT x = x
prettyItem :: Entry -> String
prettyItem (EPackage x) = "package " ++ strUnpack x
prettyItem (EModule x) = "module " ++ strUnpack x
prettyItem (EDecl x) = pretty x
input_haddock_test :: IO ()
input_haddock_test = testing "Input.Haddock.parseLine" $ do
let a === b | fmap (map prettyItem) (parseLine a) == Right [b] = putChar '.'
| otherwise = errorIO $ show (a,b,parseLine a, fmap (map prettyItem) $ parseLine a)
let test a = a === a
test "type FilePath = [Char]"
test "data Maybe a"
test "Nothing :: Maybe a"
test "Just :: a -> Maybe a"
test "newtype Identity a"
test "foo :: Int# -> b"
test "(,,) :: a -> b -> c -> (a, b, c)"
test "data (,,) a b"
test "reverse :: [a] -> [a]"
test "reverse :: [:a:] -> [:a:]"
test "module Foo.Bar"
test "data Char"
"data Char :: *" === "data Char"
"newtype ModuleName :: *" === "newtype ModuleName"
"Progress :: !(Maybe String) -> {-# UNPACK #-} !Int -> !(Int -> Bool) -> Progress" ===
"Progress :: Maybe String -> Int -> (Int -> Bool) -> Progress"
-- Broken in the last HSE release, fixed in HSE HEAD
-- test "quotRemInt# :: Int# -> Int# -> (# Int#, Int# #)"
test "( # ) :: Int"
test "pattern MyPattern :: ()"