Copy + modify code from fpcomplete.com for hoogle #47

Application.hs

@@ -68,6 +68,7 @@ import           Handler.CompressorStatus
 import           Handler.Tag
 import           Handler.BannedTags
 import           Handler.RefreshDeprecated
+import           Handler.Hoogle
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the

Handler/Haddock.hs

@@ -5,6 +5,8 @@ module Handler.Haddock
     , getUploadDocMapR
     , putUploadDocMapR
     , createHaddockUnpacker
+    -- Exported for use in Handler.Hoogle
+    , Dirs, getDirs, dirHoogleFp
     ) where
 
 import Import

Handler/Hoogle.hs

@@ -0,0 +1,145 @@
+module Handler.Hoogle where
+
+import           Control.Spoon (spoon)
+import           Data.Data (Data (..))
+import           Data.Slug (SnapSlug)
+import           Data.Text.Read (decimal)
+import           Handler.Haddock (dirHoogleFp, getDirs)
+import qualified Hoogle
+import           Import
+import           Text.Blaze.Html (preEscapedToHtml)
+import           Control.DeepSeq (NFData(..))
+import           Control.DeepSeq.Generics (genericRnf)
+
+getHoogleR :: SnapSlug -> Handler Html
+getHoogleR slug = do
+    dirs <- getDirs
+    mquery <- lookupGetParam "q"
+    mpage <- lookupGetParam "page"
+    exact <- maybe False (const True) <$> lookupGetParam "exact"
+    mresults' <- lookupGetParam "results"
+    let count' =
+            case decimal <$> mresults' of
+                Just (Right (i, "")) -> min perPage i
+                _ -> perPage
+        page =
+            case decimal <$> mpage of
+                Just (Right (i, "")) -> i
+                _ -> 1
+        offset = (page - 1) * perPage
+    Entity _ stackage <- runDB $ getBy404 $ UniqueSnapshot slug
+    let databasePath = dirHoogleFp dirs (stackageIdent stackage) ["default.hoo"]
+        heDatabase = liftIO $ Hoogle.loadDatabase (fpToString databasePath)
+    mresults <- case mquery of
+        Just query -> runHoogleQuery heDatabase HoogleQueryInput
+            { hqiQueryInput = query
+            , hqiExactSearch = if exact then Just query else Nothing
+            , hqiLimitTo = count'
+            , hqiOffsetBy = offset
+            }
+        Nothing -> return $ HoogleQueryBad "No query provided"
+    let q = fromMaybe "" mquery
+        pageLink p = (HoogleR slug
+            , (if exact then (("exact", "true"):) else id)
+            $ (maybe id (\q' -> (("q", q'):)) mquery)
+              [("page", tshow p)])
+        hoogleForm = $(widgetFile "hoogle-form")
+    defaultLayout $ do
+        setTitle "Hoogle Search"
+        $(widgetFile "hoogle")
+
+getPageCount :: Int -> Int
+getPageCount totalCount = 1 + div totalCount perPage
+
+perPage :: Int
+perPage = 10
+
+data HoogleQueryInput = HoogleQueryInput
+    { hqiQueryInput  :: Text
+    , hqiExactSearch :: Maybe Text
+    , hqiLimitTo     :: Int
+    , hqiOffsetBy    :: Int
+    }
+    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 HoogleResult = HoogleResult
+    { hrURL     :: String
+    , hrSources :: [(PackageLink, [ModuleLink])]
+    , hrTitle   :: String -- ^ HTML
+    , hrBody    :: String -- ^ plain text
+    }
+    deriving (Eq, Read, Show, Data, Typeable, Ord, Generic)
+
+data PackageLink = PackageLink
+    { plName :: String
+    , plURL  :: String
+    }
+    deriving (Eq, Read, Show, Data, Typeable, Ord, Generic)
+
+data ModuleLink = ModuleLink
+    { mlName :: String
+    , mlURL :: String
+    }
+    deriving (Eq, Read, Show, Data, Typeable, Ord, Generic)
+
+instance NFData HoogleResult where rnf = genericRnf
+instance NFData PackageLink where rnf = genericRnf
+instance NFData ModuleLink where rnf = genericRnf
+
+runHoogleQuery :: Monad m
+               => m Hoogle.Database
+               -> HoogleQueryInput
+               -> m HoogleQueryOutput
+runHoogleQuery heDatabase HoogleQueryInput {..} =
+    runQuery $ Hoogle.parseQuery Hoogle.Haskell query
+  where
+    query = unpack hqiQueryInput
+
+    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 >= 100 = 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'
+
+    classifier = maybe Nothing
+        (const (Just Hoogle.UnclassifiedItem))
+        hqiExactSearch
+
+    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
+            }
+
+    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

config/routes

@@ -33,6 +33,7 @@
 /progress/#Int ProgressR GET
 /system SystemR GET
 /haddock/#SnapSlug/*Texts HaddockR GET
+/hoogle/#SnapSlug HoogleR GET
 /package/#PackageName PackageR GET
 /package/#PackageName/snapshots PackageSnapshotsR GET
 /package PackageListR GET

stackage-server.cabal

@@ -45,6 +45,7 @@ library
                      Handler.Progress
                      Handler.System
                      Handler.Haddock
+                     Handler.Hoogle
                      Handler.Package
                      Handler.PackageList
                      Handler.CompressorStatus
@@ -82,6 +83,7 @@ library
                 RecordWildCards
                 ScopedTypeVariables
                 BangPatterns
+                DeriveGeneric
 
     build-depends:
                     base                          >= 4
@@ -151,6 +153,9 @@ library
                  , haddock-library
                  , yesod-gitrepo
                  , hoogle
+                 , spoon
+                 , deepseq
+                 , deepseq-generics
 
 executable         stackage-server
     if flag(library-only)

templates/hoogle-form.hamlet

@@ -0,0 +1,6 @@
+<form action=@{HoogleR slug}>
+    <input type=search autofocus name=q value=#{q} placeholder="Hoogle Search Phrase" .search>
+    <input .btn type="submit" value="Search">
+    <label .checkbox .exact-lookup for=exact title="Only find identifiers matching your search term precisely">
+        <input type=checkbox name=exact :exact:checked #exact>
+        Exact lookup

templates/hoogle-form.lucius

@@ -0,0 +1,8 @@
+input[type=submit] {
+  margin-bottom: 10px;
+}
+
+.exact-lookup {
+  display: inline-block;
+  margin-left: 0.5em;
+}

templates/hoogle.hamlet

@@ -0,0 +1,37 @@
+<div .container>
+    <div .content>
+        <h1>Hoogle Search
+        ^{hoogleForm}
+        $case mresults
+            $of HoogleQueryBad _err
+            $of HoogleQueryOutput query results mtotalCount
+                <p>Searched for: #{preEscapedToHtml query}
+                $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

templates/hoogle.lucius

@@ -0,0 +1,53 @@
+ol.search-results {
+  margin: 0;
+  padding: 0;
+  list-style: none;
+}
+
+.self {
+  margin-bottom: 0;
+}
+
+table.sources {
+  margin: 0;
+  padding: 0;
+  font-size: 0.8em;
+
+  th {
+    padding-right: 0.5em;
+  }
+
+  a, a:visited {
+    color: #060;
+  }
+}
+
+.docs {
+  white-space: pre-wrap;
+  background: #f8f8f8;
+}
+
+.docs, .nodocs {
+  margin-left: 1em;
+  padding: 0.5em;
+}
+
+.nodocs {
+  font-style: italic;
+}
+
+.haddocks {
+  font-weight: bold;
+  margin-bottom: 1em;
+
+  ul {
+      display: inline;
+      padding: 0;
+      margin: 0;
+  }
+  li {
+      display: inline-block;
+      font-weight: normal;
+      margin-left: 1em;
+  }
+}