diff --git a/Application.hs b/Application.hs index 13bf124..71dd537 100644 --- a/Application.hs +++ b/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 diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs index 0401e88..4fea1e7 100644 --- a/Handler/Haddock.hs +++ b/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 diff --git a/Handler/Hoogle.hs b/Handler/Hoogle.hs new file mode 100644 index 0000000..a5fa016 --- /dev/null +++ b/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 diff --git a/config/routes b/config/routes index 6bd1d22..2369518 100644 --- a/config/routes +++ b/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 diff --git a/stackage-server.cabal b/stackage-server.cabal index a4d7524..4d9570c 100644 --- a/stackage-server.cabal +++ b/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) diff --git a/templates/hoogle-form.hamlet b/templates/hoogle-form.hamlet new file mode 100644 index 0000000..5da79cf --- /dev/null +++ b/templates/hoogle-form.hamlet @@ -0,0 +1,6 @@ +
+ + +