Merge pull request #180 from fpco/hoogle5

Hoogle5 support

.dir-locals.el

@@ -1,4 +1,5 @@
 ((haskell-mode . ((haskell-indent-spaces . 4)
+                  (hindent-style . "johan-tibell")
                   (haskell-process-type . cabal-repl)
                   (haskell-process-use-ghci . t)))
  (hamlet-mode . ((hamlet/basic-offset . 4)

DevelMain.hs

@@ -16,13 +16,11 @@ import Data.IORef
 import Foreign.Store
 import Network.Wai.Handler.Warp
 import Yesod
-import Yesod.Static
 
 -- | Start the web server.
 main :: IO (Store (IORef Application))
 main =
-  do s <- static "static"
-     c <- newChan
+  do c <- newChan
      (settings,app) <- getApplicationDev
      ref <- newIORef app
      tid <- forkIO
@@ -46,7 +44,6 @@ update =
          do ref <- readStore store
             c <- readStore (Store 2)
             writeChan c ()
-            s <- static "static"
-            (_settings,app) <- getApplicationDev
+            (_,app) <- getApplicationDev
             writeIORef ref app
             return store

Handler/Haddock.hs

@@ -20,57 +20,74 @@ shouldRedirect = False
 
 getHaddockR :: SnapName -> [Text] -> Handler TypedContent
 getHaddockR slug rest
-  | shouldRedirect = redirect $ makeURL slug rest
-  | final:_ <- reverse rest, ".html" `isSuffixOf` final = track "Handler.Haddock.getHaddockR" $ do
+  | shouldRedirect = do
+      result <- redirectWithVersion slug rest
+      case result of
+        Just route -> redirect route
+        Nothing -> redirect $ makeURL slug rest
+  | final:_ <- reverse rest, ".html" `isSuffixOf` final = do
       render <- getUrlRender
-
-      let stylesheet = render' $ StaticR haddock_style_css
-          script = render' $ StaticR haddock_script_js
-          bootstrap = render' $ StaticR haddock_bootstrap_css
-          jquery = render' $ StaticR haddock_jquery_js
-          render' = return . ContentText . render
-
-          addExtra t@(EventEndElement "head") =
-            [ EventBeginElement "link"
-                [ ("rel", [ContentText "stylesheet"])
-                , ("href", bootstrap)
-                ]
-            , EventEndElement "link"
-            , EventBeginElement "link"
-                 [ ("rel", [ContentText "stylesheet"])
-                 , ("href", [ContentText "https://fonts.googleapis.com/css?family=Open+Sans"])
-                 ]
-            , EventEndElement "link"
-            , EventBeginElement "link"
-                 [ ("rel", [ContentText "stylesheet"])
-                 , ("href", stylesheet)
-                 ]
-            , EventEndElement "link"
-            , EventBeginElement "script"
-                [ ("src", jquery)
-                ]
-            , EventEndElement "script"
-            , EventBeginElement "script"
-                [ ("src", script)
-                ]
-            , EventEndElement "script"
-            , t
-            ]
-          addExtra t@(EventBeginElement "body" _) = [t] ++ nav
-          addExtra t = [t]
-
-      req <- parseUrl $ unpack $ makeURL slug rest
-      (_, res) <- acquireResponse req >>= allocateAcquire
-
-      doc <- responseBody res
-          $$ eventConduit
-          =$ concatMapC addExtra
-          =$ mapC (Nothing, )
-          =$ fromEvents
-
-      sendResponse $ toHtml doc
+      result <- redirectWithVersion slug rest
+      case result of
+        Just route -> redirect route
+        Nothing -> do
+            let stylesheet = render' $ StaticR haddock_style_css
+                script = render' $ StaticR haddock_script_js
+                bootstrap = render' $ StaticR haddock_bootstrap_css
+                jquery = render' $ StaticR haddock_jquery_js
+                render' = return . ContentText . render
+                addExtra t@(EventEndElement "head") =
+                  [ EventBeginElement "link"
+                      [ ("rel", [ContentText "stylesheet"])
+                      , ("href", bootstrap)
+                      ]
+                  , EventEndElement "link"
+                  , EventBeginElement "link"
+                       [ ("rel", [ContentText "stylesheet"])
+                       , ("href", [ContentText "https://fonts.googleapis.com/css?family=Open+Sans"])
+                       ]
+                  , EventEndElement "link"
+                  , EventBeginElement "link"
+                       [ ("rel", [ContentText "stylesheet"])
+                       , ("href", stylesheet)
+                       ]
+                  , EventEndElement "link"
+                  , EventBeginElement "script"
+                      [ ("src", jquery)
+                      ]
+                  , EventEndElement "script"
+                  , EventBeginElement "script"
+                      [ ("src", script)
+                      ]
+                  , EventEndElement "script"
+                  , t
+                  ]
+                addExtra t@(EventBeginElement "body" _) = [t] ++ nav
+                addExtra t = [t]
+            req <- parseUrl $ unpack $ makeURL slug rest
+            (_, res) <- acquireResponse req >>= allocateAcquire
+            doc <- responseBody res
+                $$ eventConduit
+                =$ concatMapC addExtra
+                =$ mapC (Nothing, )
+                =$ fromEvents
+            sendResponse $ toHtml doc
   | otherwise = redirect $ makeURL slug rest
 
+redirectWithVersion
+  :: (GetStackageDatabase m,MonadHandler m,RedirectUrl (HandlerSite m) (Route App))
+  => SnapName -> [Text] -> m (Maybe (Route App))
+redirectWithVersion slug rest =
+    case rest of
+        [pkg,file] -> do
+            Entity sid _ <- lookupSnapshot slug >>= maybe notFound return
+            mversion <- getPackageVersionBySnapshot sid pkg
+            case mversion of
+                Nothing -> return Nothing -- error "That package is not part of this snapshot."
+                Just version -> do
+                    return (Just (HaddockR slug [pkg <> "-" <> version, file]))
+        _ -> return Nothing
+
 nav :: [Event]
 nav =
   el "nav"
@@ -100,6 +117,6 @@ nav =
                 close = [EventEndElement name]
 
 getHaddockBackupR :: [Text] -> Handler ()
-getHaddockBackupR rest = track "Handler.Haddock.getHaddockBackupR" $ redirect $ concat
+getHaddockBackupR rest = track "Handler.Haddock.getHaddockBackupR" $  redirect $ concat
     $ "https://s3.amazonaws.com/haddock.stackage.org"
     : map (cons '/') rest

Handler/Hoogle.hs

@@ -1,15 +1,16 @@
+{-# LANGUAGE QuasiQuotes #-}
 module Handler.Hoogle where
 
 import           Control.DeepSeq (NFData(..))
 import           Control.DeepSeq.Generics (genericRnf)
-import           Control.Spoon (spoon)
-import           Data.Data (Data (..))
+import           Data.Data (Data)
 import           Data.Text.Read (decimal)
 import qualified Hoogle
 import           Import
 import           Text.Blaze.Html (preEscapedToHtml)
 import Stackage.Database
 import qualified Stackage.Database.Cron as Cron
+import qualified Data.Text as T
 
 getHoogleDB :: SnapName -> Handler (Maybe FilePath)
 getHoogleDB name = track "Handler.Hoogle.getHoogleDB" $ do
@@ -21,7 +22,7 @@ getHoogleR name = track "Handler.Hoogle.getHoogleR" $ do
     Entity _ snapshot <- lookupSnapshot name >>= maybe notFound return
     mquery <- lookupGetParam "q"
     mpage <- lookupGetParam "page"
-    exact <- maybe False (const True) <$> lookupGetParam "exact"
+    exact <- isJust <$> lookupGetParam "exact"
     mresults' <- lookupGetParam "results"
     let count' =
             case decimal <$> mresults' of
@@ -33,25 +34,32 @@ getHoogleR name = track "Handler.Hoogle.getHoogleR" $ do
                 _ -> 1
         offset = (page - 1) * perPage
     mdatabasePath <- getHoogleDB name
-    heDatabase <- case mdatabasePath of
-        Just x -> return $ liftIO $ Hoogle.loadDatabase x
-        Nothing -> hoogleDatabaseNotAvailableFor name
+    dbPath <- maybe (hoogleDatabaseNotAvailableFor name) return mdatabasePath
 
     -- Avoid concurrent Hoogle queries, see
     -- https://github.com/fpco/stackage-server/issues/172
     lock <- appHoogleLock <$> getYesod
-    mresults <- case mquery of
-        Just query -> withMVar lock $ const $ runHoogleQuery heDatabase HoogleQueryInput
-            { hqiQueryInput = query
-            , hqiExactSearch = if exact then Just query else Nothing
-            , hqiLimitTo = count'
-            , hqiOffsetBy = offset
-            }
-        Nothing -> return $ HoogleQueryOutput "" [] Nothing
+    urlRender <- getUrlRender
+    HoogleQueryOutput results mtotalCount <-
+      case mquery of
+        Just query -> do
+            let input = HoogleQueryInput
+                    { hqiQueryInput = query
+                    , hqiLimitTo = count'
+                    , hqiOffsetBy = offset
+                    , hqiExact = exact
+                    }
+
+            liftIO $ withMVar lock
+                   $ const
+                   $ Hoogle.withDatabase dbPath
+                   -- NB! I got a segfault when I didn't force with $!
+                   $ \db -> return $! runHoogleQuery urlRender name db input
+        Nothing -> return $ HoogleQueryOutput [] Nothing
     let queryText = fromMaybe "" mquery
         pageLink p = (SnapshotR name HoogleR
             , (if exact then (("exact", "true"):) else id)
-            $ (maybe id (\q' -> (("q", q'):)) mquery)
+            $ maybe id (\q' -> (("q", q'):)) mquery
               [("page", tshow p)])
         snapshotLink = SnapshotR name StackageHomeR
         hoogleForm = $(widgetFile "hoogle-form")
@@ -85,15 +93,15 @@ perPage = 10
 
 data HoogleQueryInput = HoogleQueryInput
     { hqiQueryInput  :: Text
-    , hqiExactSearch :: Maybe Text
     , hqiLimitTo     :: Int
     , hqiOffsetBy    :: Int
+    , hqiExact       :: Bool
     }
     deriving (Eq, Read, Show, Data, Typeable, Ord, Generic)
 
-data HoogleQueryOutput = HoogleQueryBad Text
-                       | HoogleQueryOutput Text [HoogleResult] (Maybe Int) -- ^ Text == HTML version of query, Int == total count
-    deriving (Read, Typeable, Data, Show, Eq)
+data HoogleQueryOutput = HoogleQueryOutput [HoogleResult] (Maybe Int) -- ^ Int == total count
+    deriving (Read, Typeable, Data, Show, Eq, Generic)
+instance NFData HoogleQueryOutput where rnf = genericRnf
 
 data HoogleResult = HoogleResult
     { hrURL     :: String
@@ -119,57 +127,52 @@ instance NFData HoogleResult where rnf = genericRnf
 instance NFData PackageLink where rnf = genericRnf
 instance NFData ModuleLink where rnf = genericRnf
 
-runHoogleQuery :: MonadIO m
-               => m Hoogle.Database
+runHoogleQuery :: (Route App -> Text)
+               -> SnapName
+               -> Hoogle.Database
                -> HoogleQueryInput
-               -> m HoogleQueryOutput
-runHoogleQuery heDatabase HoogleQueryInput {..} =
-    track "Handler.Hoogle.runHoogleQuery" $
-    runQuery $ Hoogle.parseQuery Hoogle.Haskell query
+               -> HoogleQueryOutput
+runHoogleQuery renderUrl snapshot hoogledb HoogleQueryInput {..} =
+    HoogleQueryOutput targets mcount
   where
-    query = unpack hqiQueryInput
+    allTargets = Hoogle.searchDatabase hoogledb query
+    targets = take (min 100 hqiLimitTo)
+            $ drop hqiOffsetBy
+            $ map fixResult allTargets
+    query = unpack $ hqiQueryInput ++ if hqiExact then " is:exact" else ""
 
-    runQuery (Left err) = return $ HoogleQueryBad (tshow err)
-    runQuery (Right query') = do
-        hoogledb <- heDatabase
-        let query'' = Hoogle.queryExact classifier query'
-            rawRes  = concatMap fixResult
-                    $ Hoogle.search hoogledb query''
-            mres    = spoon
-                    $ take (min 100 hqiLimitTo)
-                    $ drop hqiOffsetBy rawRes
-            mcount  = spoon $ limitedLength 0 rawRes
-            limitedLength x [] = Just x
-            limitedLength x (_:rest)
-                | x >= 20 = Nothing
-                | otherwise = limitedLength (x + 1) rest
-            rendered = pack $ Hoogle.showTagHTML $ Hoogle.renderQuery query''
-        return $ case (,) <$> mres <*> mcount of
-            Nothing ->
-                HoogleQueryOutput rendered [] (Just 0)
-            Just (results, mcount') ->
-                HoogleQueryOutput rendered (take hqiLimitTo results) mcount'
+    mcount = limitedLength 0 allTargets
 
-    classifier = maybe Nothing
-        (const (Just Hoogle.UnclassifiedItem))
-        hqiExactSearch
+    limitedLength x [] = Just x
+    limitedLength x (_:rest)
+        | x >= 20 = Nothing
+        | otherwise = limitedLength (x + 1) rest
 
-    fixResult (_, Hoogle.Result locs self docs) = do
-        (loc, _) <- take 1 locs
-        let sources' = unionsWith (++) $
-                mapMaybe (getPkgModPair . snd) locs
-        return HoogleResult
-            { hrURL     = loc
-            , hrSources = mapToList sources'
-            , hrTitle   = Hoogle.showTagHTML self
-            , hrBody    = fromMaybe "Problem loading documentation" $
-                              spoon $ Hoogle.showTagText docs
-            }
+    fixResult Hoogle.Target {..} = HoogleResult
+        { hrURL     = case sources of
+                        [(_,[ModuleLink _ m])] -> m ++ haddockAnchorFromUrl targetURL
+                        _ -> targetURL
+        , hrSources = sources
+        , hrTitle   = -- FIXME find out why these replaces are necessary
+                      unpack $ T.replace "<0>" "" $ T.replace "</0>" "" $ pack
+                      targetItem
+        , hrBody    = targetDocs
+        }
+      where sources = toList $ do
+              (pname, _) <- targetPackage
+              (mname, _) <- targetModule
+              let p = PackageLink pname (makePackageLink pname)
+                  m = ModuleLink
+                        mname
+                        (T.unpack
+                             (renderUrl
+                                  (haddockUrl
+                                       snapshot
+                                       (T.pack pname)
+                                       (T.pack mname))))
+              Just (p, [m])
+            haddockAnchorFromUrl =
+                ('#':) . reverse . takeWhile (/='#') . reverse
 
-    getPkgModPair :: [(String, String)]
-                  -> Maybe (Map PackageLink [ModuleLink])
-    getPkgModPair [(pkg, pkgname), (modu, moduname)] = do
-        let pkg' = PackageLink pkgname pkg
-            modu' = ModuleLink moduname modu
-        return $ asMap $ singletonMap pkg' [modu']
-    getPkgModPair _ = Nothing
+makePackageLink :: String -> String
+makePackageLink pkg = "/package/" ++ pkg

Stackage/Database.hs

@@ -15,6 +15,7 @@ module Stackage.Database
     , PackageListingInfo (..)
     , getAllPackages
     , getPackages
+    , getPackageVersionBySnapshot
     , createStackageDatabase
     , openStackageDatabase
     , ModuleListingInfo (..)
@@ -526,6 +527,22 @@ getPackages sid = liftM (map toPLI) $ run $ do
         , pliIsCore = isCore
         }
 
+getPackageVersionBySnapshot
+  :: GetStackageDatabase m
+  => SnapshotId -> Text -> m (Maybe Text)
+getPackageVersionBySnapshot sid name = liftM (listToMaybe . map toPLI) $ run $ do
+    E.select $ E.from $ \(p,sp) -> do
+        E.where_ $
+            (p E.^. PackageId E.==. sp E.^. SnapshotPackagePackage) E.&&.
+            (sp E.^. SnapshotPackageSnapshot E.==. E.val sid) E.&&.
+            (E.lower_ (p E.^. PackageName) E.==. E.lower_ (E.val name))
+        E.orderBy [E.asc $ E.lower_ $ p E.^. PackageName]
+        return
+            ( sp E.^. SnapshotPackageVersion
+            )
+  where
+    toPLI (E.Value version) = version
+
 data ModuleListingInfo = ModuleListingInfo
     { mliName :: !Text
     , mliPackageVersion :: !Text

Stackage/Database/Cron.hs

@@ -7,16 +7,13 @@ module Stackage.Database.Cron
 import ClassyPrelude.Conduit
 import Stackage.PackageIndex.Conduit
 import Database.Persist (Entity (Entity))
-import Data.Char (isAlpha)
 import qualified Codec.Archive.Tar as Tar
 import Stackage.Database
 import Network.HTTP.Client
 import Network.HTTP.Client.Conduit (bodyReaderSource)
-import Filesystem (rename, removeTree, removeFile)
+import Filesystem (rename, removeTree, removeFile, isFile, createTree)
 import Web.PathPieces (toPathPiece)
-import Filesystem (isFile, createTree)
 import Filesystem.Path.CurrentOS (parent, fromText, encodeString)
-import Control.Monad.State.Strict (StateT, get, put)
 import Network.HTTP.Types (status200)
 import           Data.Streaming.Network (bindPortTCP)
 import           Network.AWS                   (Credentials (Discover),
@@ -35,6 +32,7 @@ import           Data.Conduit.Zlib             (WindowBits (WindowBits),
                                                 compress, ungzip)
 import qualified Hoogle
 import System.Directory (doesFileExist)
+import System.IO.Temp (withSystemTempDirectory)
 
 filename' :: Text
 filename' = concat
@@ -208,6 +206,7 @@ stackageServerCron = do
 
 createHoogleDB :: StackageDatabase -> Manager -> SnapName -> IO (Maybe FilePath)
 createHoogleDB db man name = handleAny (\e -> print e $> Nothing) $ do
+    putStrLn $ "Creating Hoogle DB for " ++ toPathPiece name
     req' <- parseUrl $ unpack tarUrl
     let req = req' { decompress = const True }
 
@@ -222,16 +221,26 @@ createHoogleDB db man name = handleAny (\e -> print e $> Nothing) $ do
     void $ tryIO $ removeFile (fromString outname)
     createTree (fromString bindir)
 
-    dbs <- runResourceT
-        $ sourceTarFile False tarFP
-       $$ evalStateC 1 (mapMC (singleDB db name bindir))
-       =$ sinkList
+    withSystemTempDirectory ("hoogle-" ++ unpack (toPathPiece name)) $ \tmpdir -> do
+        runResourceT
+            $ sourceTarFile False tarFP
+           $$ mapM_C (liftIO . singleDB db name tmpdir)
 
-    putStrLn "Merging databases..."
-    Hoogle.mergeDatabase (catMaybes dbs) outname
-    putStrLn "Merge done"
+        let args =
+                [ "generate"
+                , "--database=" ++ outname
+                , "--local=" ++ tmpdir
+                ]
+        putStrLn $ concat
+            [ "Merging databases... ("
+            , tshow args
+            , ")"
+            ]
+        Hoogle.hoogle args
 
-    return $ Just outname
+        putStrLn "Merge done"
+
+        return $ Just outname
   where
     root = "hoogle-gen"
     bindir = root </> "bindir"
@@ -243,81 +252,29 @@ createHoogleDB db man name = handleAny (\e -> print e $> Nothing) $ do
 
 singleDB :: StackageDatabase
          -> SnapName
-         -> FilePath -- ^ bindir to write to
+         -> FilePath -- ^ temp directory to write .txt files to
          -> Tar.Entry
-         -> StateT Int (ResourceT IO) (Maybe FilePath)
-singleDB db sname bindir e@(Tar.entryContent -> Tar.NormalFile lbs _) = do
-    idx <- get
-    put $! idx + 1
-    putStrLn $ "Loading file for Hoogle: " ++ pack (Tar.entryPath e)
+         -> IO ()
+singleDB db sname tmpdir e@(Tar.entryContent -> Tar.NormalFile lbs _) = do
+    --putStrLn $ "Loading file for Hoogle: " ++ pack (Tar.entryPath e)
 
     let pkg = pack $ takeWhile (/= '.') $ Tar.entryPath e
     msp <- flip runReaderT db $ do
         Just (Entity sid _) <- lookupSnapshot sname
         lookupSnapshotPackage sid pkg
     case msp of
-        Nothing -> do
-            putStrLn $ "Unknown: " ++ pkg
-            return Nothing
-        Just (Entity _ sp) -> do
-            let ver = snapshotPackageVersion sp
-                pkgver = concat [pkg, "-", ver]
-                out = bindir </> show idx <.> "hoo"
-                src' = unlines
-                     $ haddockHacks (Just $ unpack docsUrl)
-                     $ lines
-                     $ unpack
-                     $ decodeUtf8 lbs
+        Nothing -> putStrLn $ "Unknown: " ++ pkg
+        Just _ -> do
+            let out = tmpdir </> unpack pkg <.> "txt"
+                -- FIXME add @url directive
+            writeFile out lbs
+                {-
                 docsUrl = concat
                     [ "https://www.stackage.org/haddock/"
                     , toPathPiece sname
                     , "/"
                     , pkgver
                     , "/index.html"
-                    ]
+                    ] -}
 
-            _errs <- liftIO $ Hoogle.createDatabase "" Hoogle.Haskell [] src' out
-
-            return $ Just out
-singleDB _ _ _ _ = return Nothing
-
----------------------------------------------------------------------
--- HADDOCK HACKS
--- (Copied from hoogle-4.2.36/src/Recipe/Haddock.hs)
--- Modifications:
--- 1) Some name qualification
--- 2) Explicit type sig due to polymorphic elem
--- 3) Fixed an unused binding warning
-
--- Eliminate @version
--- Change :*: to (:*:), Haddock bug
--- Change !!Int to !Int, Haddock bug
--- Change instance [overlap ok] to instance, Haddock bug
--- Change instance [incoherent] to instance, Haddock bug
--- Change instance [safe] to instance, Haddock bug
--- Change !Int to Int, HSE bug
--- Drop {-# UNPACK #-}, Haddock bug
--- Drop everything after where, Haddock bug
-
-haddockHacks :: Maybe Hoogle.URL -> [String] -> [String]
-haddockHacks loc src = maybe id haddockPackageUrl loc (translate src)
-    where
-        translate :: [String] -> [String]
-        translate = map (unwords . g . map f . words) . filter (not . isPrefixOf "@version ")
-
-        f "::" = "::"
-        f (':':xs) = "(:" ++ xs ++ ")"
-        f ('!':'!':x:xs) | isAlpha x = xs
-        f ('!':x:xs) | isAlpha x || x `elem` ("[(" :: String) = x:xs
-        f x | x `elem` ["[overlap","ok]","[incoherent]","[safe]"] = ""
-        f x | x `elem` ["{-#","UNPACK","#-}"] = ""
-        f x = x
-
-        g ("where":_) = []
-        g (x:xs) = x : g xs
-        g [] = []
-
-haddockPackageUrl :: Hoogle.URL -> [String] -> [String]
-haddockPackageUrl x = concatMap f
-    where f y | "@package " `isPrefixOf` y = ["@url " ++ x, y]
-              | otherwise = [y]
+singleDB _ _ _ _ = return ()

stack.yaml

@@ -1,4 +1,10 @@
 resolver: lts-5.15
+packages:
+- .
+- location:
+    git: https://github.com/snoyberg/hoogle.git
+    commit: 765bd653d687e8569cd989be1637de86dcb20d56
+  extra-dep: true
 image:
     container:
         name: fpco/stackage-server

stackage-server.cabal

@@ -161,7 +161,7 @@ library
                   , haddock-library               >= 1.2.0       &&   < 1.3
                   , async                         >= 2.1         &&   < 2.2
                   , yesod-gitrepo                 >= 0.2         &&   < 0.3
-                  , hoogle                        >= 4.2         &&   < 4.3
+                  , hoogle
                   , spoon                         >= 0.3         &&   < 0.4
                   , deepseq                       >= 1.4         &&   < 1.5
                   , deepseq-generics              >= 0.1         &&   < 0.2

templates/hoogle.hamlet

@@ -3,37 +3,32 @@
         <h1>Hoogle Search
         <p>Within <a href=@{snapshotLink}>#{snapshotTitle snapshot}</a>
         ^{hoogleForm}
-        $case mresults
-            $of HoogleQueryBad err
-                <p>#{err}
-                <p>For information on what queries should look like, see the <a href="http://www.haskell.org/haskellwiki/Hoogle">hoogle user manual</a>.
-            $of HoogleQueryOutput _query results mtotalCount
-                $if null results
-                    <p>Your search produced no results.
-                $else
-                    <ol .search-results>
-                        $forall HoogleResult url sources self docs <- results
-                            <li>
-                                <p .self>
-                                    <a href=#{url}>#{preEscapedToHtml self}
-                                <table .sources>
-                                    $forall (pkg, modus) <- sources
-                                        <tr>
-                                            <th>
-                                                <a href=#{plURL pkg}>#{plName pkg}
-                                            <td>
-                                                $forall ModuleLink name url' <- modus
-                                                    <a href=#{url'}>#{name}
-                                $if null docs
-                                    <p .nodocs>No documentation available.
-                                $else
-                                    <p .docs>#{docs}
-                    <p .pagination>
-                        $with mpageCount <- fmap getPageCount mtotalCount
-                            Page #{page} of #{maybe "many" show mpageCount} #
-                            $if page > 1
-                                |
-                                <a href=@?{pageLink $ page - 1}>Previous
-                            $if maybe True ((<) page) mpageCount
-                                |
-                                <a href=@?{pageLink $ page + 1}>Next
+        $if null results
+            <p>Your search produced no results.
+        $else
+            <ol .search-results>
+                $forall HoogleResult url sources self docs <- results
+                    <li>
+                        <p .self>
+                            <a href=#{url}>#{preEscapedToHtml self}
+                        <table .sources>
+                            $forall (pkg, modus) <- sources
+                                <tr>
+                                    <th>
+                                        <a href=#{plURL pkg}>#{plName pkg}
+                                    <td>
+                                        $forall ModuleLink name url' <- modus
+                                            <a href=#{url'}>#{name}
+                        $if null docs
+                            <p .nodocs>No documentation available.
+                        $else
+                            <p .docs>#{preEscapedToHtml docs}
+            <p .pagination>
+                $with mpageCount <- fmap getPageCount mtotalCount
+                    Page #{page} of #{maybe "many" show mpageCount} #
+                    $if page > 1
+                        |
+                        <a href=@?{pageLink $ page - 1}>Previous
+                    $if maybe True ((<) page) mpageCount
+                        |
+                        <a href=@?{pageLink $ page + 1}>Next