haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-01-21 16:31:56 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Fix full-module Hoogle link results #215

Browse Source
This commit is contained in:
Michael Snoyman 2016-12-05 09:27:19 -05:00
parent 6dd5604444
commit 7e342157f9
1 changed files with 13 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
Handler/Hoogle.hs
View File

@ -10,6 +10,8 @@ import Import
import Text.Blaze.Html (preEscapedToHtml) import Text.Blaze.Html (preEscapedToHtml)
import Stackage.Database import Stackage.Database
import qualified Data.Text as T import qualified Data.Text as T
import qualified Text.HTML.DOM
import Text.XML.Cursor (fromDocument, ($//), content)
getHoogleDB :: SnapName -> Handler (Maybe FilePath) getHoogleDB :: SnapName -> Handler (Maybe FilePath)
getHoogleDB name = track "Handler.Hoogle.getHoogleDB" $ do getHoogleDB name = track "Handler.Hoogle.getHoogleDB" $ do
@ -154,7 +156,7 @@ runHoogleQuery renderUrl snapshot hoogledb HoogleQueryInput {..} =
fixResult Hoogle.Target {..} = HoogleResult fixResult Hoogle.Target {..} = HoogleResult
{ hrURL = case sources of { hrURL = case sources of
[(_,[ModuleLink _ m])] -> m ++ haddockAnchorFromUrl targetURL [(_,[ModuleLink _ m])] -> m ++ haddockAnchorFromUrl targetURL
_ -> targetURL _ -> fromMaybe targetURL moduleLink
, hrSources = sources , hrSources = sources
, hrTitle = -- FIXME find out why these replaces are necessary , hrTitle = -- FIXME find out why these replaces are necessary
unpack $ T.replace "<0>" "" $ T.replace "</0>" "" $ pack unpack $ T.replace "<0>" "" $ T.replace "</0>" "" $ pack
@ -174,6 +176,16 @@ runHoogleQuery renderUrl snapshot hoogledb HoogleQueryInput {..} =
(T.pack pname) (T.pack pname)
(T.pack mname)))) (T.pack mname))))
Just (p, [m]) Just (p, [m])
moduleLink = do
(pname, _) <- targetPackage
"module" <- Just targetType
let doc = Text.HTML.DOM.parseLBS $ encodeUtf8 $ pack targetItem
cursor = fromDocument doc
item = T.concat $ cursor $// content
mname <- T.stripPrefix "module " item
return $ T.unpack $ renderUrl $ haddockUrl snapshot (T.pack pname) mname
haddockAnchorFromUrl = haddockAnchorFromUrl =
('#':) . reverse . takeWhile (/='#') . reverse ('#':) . reverse . takeWhile (/='#') . reverse