From cf839b71b1c85893293840dc3ab70fd7dae3e72b Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Sat, 8 Oct 2022 10:21:21 +0200 Subject: [PATCH 01/14] Action/Server: Document grab* functions --- src/Action/Server.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Action/Server.hs b/src/Action/Server.hs index f623d7d8..0590581a 100644 --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -88,8 +88,15 @@ replyServer :: Log -> Bool -> Bool -> Maybe FilePath -> StoreRead -> String -> S replyServer log local links haddock store cdn home htmlDir scope Input{..} = case inputURL of -- without -fno-state-hack things can get folded under this lambda [] -> do - let grabBy name = [x | (a,x) <- inputArgs, name a, x /= ""] + let + -- take from inputArgs, if namePred and value not empty + grabBy :: (String -> Bool) -> [String] + grabBy namePred = [x | (a,x) <- inputArgs, namePred a, x /= ""] + -- take from input Args if value not empty + grab :: String -> [String] grab name = grabBy (== name) + -- take an int from input Args, iff exists, else use default value + grabInt :: String -> Int -> Int grabInt name def = fromMaybe def $ readMaybe =<< listToMaybe (grab name) :: Int let qScope = let xs = grab "scope" in [scope | null xs && scope /= ""] ++ xs From ba4f4c3fc954b47b987d0839c7bbd9e48e46d73d Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Sat, 8 Oct 2022 10:21:37 +0200 Subject: [PATCH 02/14] Action/Server: Pass url options as one argument MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The `local` and `haddock` booleans are only used for determining the URLs to generate, so let’s make that clear. --- src/Action/Server.hs | 35 +++++++++++++++++++++-------------- 1 file changed, 21 insertions(+), 14 deletions(-) diff --git a/src/Action/Server.hs b/src/Action/Server.hs index 0590581a..7a48a055 100644 --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ViewPatterns, TupleSections, RecordWildCards, ScopedTypeVariables, PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} module Action.Server(actionServer, actionReplay, action_server_test_, action_server_test) where @@ -104,7 +105,12 @@ replyServer log local links haddock store cdn home htmlDir scope Input{..} = cas let qSource = qSearch ++ filter (/= "set:stackage") qScope let q = concatMap parseQuery qSource let (q2, results) = search store q - let body = showResults local links haddock (filter ((/= "mode") . fst) inputArgs) q2 $ + + let urlOpts = if + | Just _ <- haddock -> IsHaddockUrl + | local -> IsLocalUrl + | otherwise -> IsOtherUrl + let body = showResults urlOpts links (filter ((/= "mode") . fst) inputArgs) q2 $ dedupeTake 25 (\t -> t{targetURL="",targetPackage=Nothing, targetModule=Nothing}) results case lookup "mode" inputArgs of Nothing | qSource /= [] -> fmap OutputHTML $ templateRender templateIndex @@ -151,8 +157,8 @@ replyServer log local links haddock store cdn home htmlDir scope Input{..} = cas pure $ case stats of Nothing -> OutputFail $ lbstrPack "GHC Statistics is not enabled, restart with +RTS -T" Just x -> OutputText $ lbstrPack $ replace ", " "\n" $ takeWhile (/= '}') $ drop1 $ dropWhile (/= '{') $ show x - "haddock":xs | Just x <- haddock -> do - let file = intercalate "/" $ x:xs + "haddock":xs | Just haddockFilePath <- haddock -> do + let file = intercalate "/" $ haddockFilePath:xs pure $ OutputFile $ file ++ (if hasTrailingPathSeparator file then "index.html" else "") "file":xs | local -> do let x = ['/' | not isWindows] ++ intercalate "/" (dropWhile null xs) @@ -192,20 +198,21 @@ dedupeTake n key = f [] Map.empty | otherwise = f (k:res) (Map.insert k [x] mp) xs where k = key x +data UrlOpts = IsHaddockUrl | IsLocalUrl | IsOtherUrl -showResults :: Bool -> Bool -> Maybe FilePath -> [(String, String)] -> [Query] -> [[Target]] -> Markup -showResults local links haddock args query results = do +showResults :: UrlOpts -> Bool -> [(String, String)] -> [Query] -> [[Target]] -> Markup +showResults urlOpts links args query results = do H.h1 $ renderQuery query when (null results) $ H.p "No results found" forM_ results $ \is@(Target{..}:_) -> do H.div ! H.class_ "result" $ do H.div ! H.class_ "ans" $ do - H.a ! H.href (H.stringValue $ showURL local haddock targetURL) $ + H.a ! H.href (H.stringValue $ showURL urlOpts targetURL) $ displayItem query targetItem when links $ whenJust (useLink is) $ \link -> H.div ! H.class_ "links" $ H.a ! H.href (H.stringValue link) $ "Uses" - H.div ! H.class_ "from" $ showFroms local haddock is + H.div ! H.class_ "from" $ showFroms urlOpts is H.div ! H.class_ "doc newline shut" $ H.preEscapedString targetDocs H.ul ! H.id "left" $ do H.li $ H.b "Packages" @@ -244,18 +251,18 @@ itemCategories xs = [("is","module") | any ((==) "module" . targetType) xs] ++ nubOrd [("package",p) | Just (p,_) <- map targetPackage xs] -showFroms :: Bool -> Maybe FilePath -> [Target] -> Markup -showFroms local haddock xs = mconcat $ intersperse ", " $ flip map pkgs $ \p -> +showFroms :: UrlOpts -> [Target] -> Markup +showFroms urlOpts xs = mconcat $ intersperse ", " $ flip map pkgs $ \p -> let ms = filter ((==) p . targetPackage) xs - in mconcat $ intersperse " " [H.a ! H.href (H.stringValue $ showURL local haddock b) $ H.string a | (a,b) <- catMaybes $ p : map remod ms] + in mconcat $ intersperse " " [H.a ! H.href (H.stringValue $ showURL urlOpts b) $ H.string a | (a,b) <- catMaybes $ p : map remod ms] where remod Target{..} = do (a,_) <- targetModule; pure (a,targetURL) pkgs = nubOrd $ map targetPackage xs -showURL :: Bool -> Maybe FilePath -> URL -> String -showURL _ (Just _) x = "haddock/" ++ dropPrefix "file:///" x -showURL True _ (stripPrefix "file:///" -> Just x) = "file/" ++ x -showURL _ _ x = x +showURL :: UrlOpts -> URL -> String +showURL IsHaddockUrl x = "haddock/" ++ dropPrefix "file:///" x +showURL IsLocalUrl (stripPrefix "file:///" -> Just x) = "file/" ++ x +showURL IsOtherUrl x = x ------------------------------------------------------------- From 2a8e6320d871140b2aa3cbcf3a8e281939e9a623 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Sat, 8 Oct 2022 11:00:11 +0200 Subject: [PATCH 03/14] Action/Server: enable -Wall & fix warnings --- src/Action/Server.hs | 57 +++++++++++++++++++++++++------------------- 1 file changed, 32 insertions(+), 25 deletions(-) diff --git a/src/Action/Server.hs b/src/Action/Server.hs index 7a48a055..06f6ade7 100644 --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ViewPatterns, TupleSections, RecordWildCards, ScopedTypeVariables, PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiWayIf #-} +{-# OPTIONS_GHC -Wall #-} module Action.Server(actionServer, actionReplay, action_server_test_, action_server_test) where @@ -31,7 +32,7 @@ import System.Time.Extra import Data.Time.Clock import Data.Time.Calendar import System.IO.Unsafe -import Numeric.Extra +import Numeric.Extra hiding (log) import System.Info.Extra import Output.Tags @@ -46,7 +47,7 @@ import Action.Search import Action.CmdLine import Control.Applicative import Data.Monoid -import Prelude +import Prelude hiding (log) import qualified Data.Aeson as JSON @@ -61,11 +62,12 @@ actionServer cmd@Server{..} = do log <- logCreate (if logs == "" then Left stdout else Right logs) $ \x -> BS.pack "hoogle=" `BS.isInfixOf` x && not (BS.pack "is:ping" `BS.isInfixOf` x) putStrLn . showDuration =<< time - evaluate spawned + _ <- evaluate spawned dataDir <- maybe getDataDir pure datadir - haddock <- maybe (pure Nothing) (fmap Just . canonicalizePath) haddock + haddock' <- maybe (pure Nothing) (fmap Just . canonicalizePath) haddock withSearch database $ \store -> - server log cmd $ replyServer log local links haddock store cdn home (dataDir "html") scope + server log cmd $ replyServer log local links haddock' store cdn home (dataDir "html") scope +actionServer _ = error "should not happen" actionReplay :: CmdLine -> IO () actionReplay Replay{..} = withBuffering stdout NoBuffering $ do @@ -80,6 +82,7 @@ actionReplay Replay{..} = withBuffering stdout NoBuffering $ do evaluate $ rnf res putChar '.' putStrLn $ "\nTook " ++ showDuration t ++ " (" ++ showDuration (t / intToDouble (repeat_ * length qs)) ++ ")" +actionReplay _ = error "should not happen" {-# NOINLINE spawned #-} spawned :: UTCTime @@ -116,9 +119,9 @@ replyServer log local links haddock store cdn home htmlDir scope Input{..} = cas Nothing | qSource /= [] -> fmap OutputHTML $ templateRender templateIndex [("tags", html $ tagOptions qScope) ,("body", html body) - ,("title", text $ unwords qSource ++ " - Hoogle") - ,("search", text $ unwords qSearch) - ,("robots", text $ if any isQueryScope q then "none" else "index")] + ,("title", txt $ unwords qSource ++ " - Hoogle") + ,("search", txt $ unwords qSearch) + ,("robots", txt $ if any isQueryScope q then "none" else "index")] | otherwise -> OutputHTML <$> templateRender templateHome [] Just "body" -> OutputHTML <$> if null qSource then templateRender templateEmpty [] else templateRender (html body) [] Just "json" -> @@ -143,15 +146,15 @@ replyServer log local links haddock store cdn home htmlDir scope Input{..} = cas summ <- logSummary log let errs = sum [summaryErrors | Summary{..} <- summ, summaryDate >= pred (utctDay now)] let alive = fromRational $ toRational $ (now `diffUTCTime` spawned) / (24 * 60 * 60) - pure $ (if errs == 0 && alive < 1.5 then OutputText else OutputFail) $ lbstrPack $ + pure $ (if errs == 0 && alive < (1.5 :: Double) then OutputText else OutputFail) $ lbstrPack $ "Errors " ++ (if errs == 0 then "good" else "bad") ++ ": " ++ show errs ++ " in the last 24 hours.\n" ++ "Updates " ++ (if alive < 1.5 then "good" else "bad") ++ ": Last updated " ++ showDP 2 alive ++ " days ago.\n" ["log"] -> do OutputHTML <$> templateRender templateLog [] ["log.js"] -> do - log <- displayLog <$> logSummary log - OutputJavascript <$> templateRender templateLogJs [("data",html $ H.preEscapedString log)] + log' <- displayLog <$> logSummary log + OutputJavascript <$> templateRender templateLogJs [("data",html $ H.preEscapedString log')] ["stats"] -> do stats <- getStatsDebug pure $ case stats of @@ -174,17 +177,17 @@ replyServer log local links haddock store cdn home htmlDir scope Input{..} = cas pure $ OutputFile $ joinPath $ htmlDir : xs where html = templateMarkup - text = templateMarkup . H.string + txt = templateMarkup . H.string tagOptions sel = mconcat [H.option Text.Blaze.!? (x `elem` sel, H.selected "selected") $ H.string x | x <- completionTags store] params = - [("cdn", text cdn) - ,("home", text home) - ,("jquery", text $ if null cdn then "plugin/jquery.js" else "https:" ++ JQuery.url) - ,("version", text $ showVersion version ++ " " ++ showUTCTime "%Y-%m-%d %H:%M" spawned)] + [("cdn", txt cdn) + ,("home", txt home) + ,("jquery", txt $ if null cdn then "plugin/jquery.js" else "https:" ++ JQuery.url) + ,("version", txt $ showVersion version ++ " " ++ showUTCTime "%Y-%m-%d %H:%M" spawned)] templateIndex = templateFile (htmlDir "index.html") `templateApply` params templateEmpty = templateFile (htmlDir "welcome.html") - templateHome = templateIndex `templateApply` [("tags",html $ tagOptions []),("body",templateEmpty),("title",text "Hoogle"),("search",text ""),("robots",text "index")] + templateHome = templateIndex `templateApply` [("tags",html $ tagOptions []),("body",templateEmpty),("title",txt "Hoogle"),("search",txt ""),("robots",txt "index")] templateLog = templateFile (htmlDir "log.html") `templateApply` params templateLogJs = templateFile (htmlDir "log.js") `templateApply` params @@ -193,7 +196,10 @@ dedupeTake :: Ord k => Int -> (v -> k) -> [v] -> [[v]] dedupeTake n key = f [] Map.empty where -- map is Map k [v] - f res mp xs | Map.size mp >= n || null xs = map (reverse . (Map.!) mp) $ reverse res + f res mp [] + = map (reverse . (Map.!) mp) $ reverse res + f res mp _ | Map.size mp >= n + = map (reverse . (Map.!) mp) $ reverse res f res mp (x:xs) | Just vs <- Map.lookup k mp = f res (Map.insert k (x:vs) mp) xs | otherwise = f (k:res) (Map.insert k [x] mp) xs where k = key x @@ -238,9 +244,9 @@ showResults urlOpts links args query results = do -- find the X bit extractName :: String -> String extractName x - | Just (_, x) <- stripInfix "" x - , Just (x, _) <- stripInfix "" x - = unHTML x + | Just (_, x') <- stripInfix "" x + , Just (x'', _) <- stripInfix "" x' + = unHTML x'' extractName x = x @@ -262,6 +268,7 @@ showFroms urlOpts xs = mconcat $ intersperse ", " $ flip map pkgs $ \p -> showURL :: UrlOpts -> URL -> String showURL IsHaddockUrl x = "haddock/" ++ dropPrefix "file:///" x showURL IsLocalUrl (stripPrefix "file:///" -> Just x) = "file/" ++ x +showURL IsLocalUrl x = x showURL IsOtherUrl x = x @@ -269,17 +276,17 @@ showURL IsOtherUrl x = x -- DISPLAY AN ITEM (bold keywords etc) highlightItem :: [Query] -> String -> Markup -highlightItem qs x - | Just (pre,x) <- stripInfix "" x, Just (name,post) <- stripInfix "" x +highlightItem qs str + | Just (pre,x) <- stripInfix "" str, Just (name,post) <- stripInfix "" x = H.preEscapedString pre <> highlight (unescapeHTML name) <> H.preEscapedString post - | otherwise = H.string x + | otherwise = H.string str where highlight = mconcatMap (\xs@((b,_):_) -> let s = H.string $ map snd xs in if b then H.b s else s) . groupOn fst . (\x -> zip (f x) x) where f (x:xs) | m > 0 = replicate m True ++ drop (m - 1) (f xs) where m = maximum $ 0 : [length y | QueryName y <- qs, lower y `isPrefixOf` lower (x:xs)] - f (x:xs) = False : f xs + f (_:xs) = False : f xs f [] = [] displayItem :: [Query] -> String -> Markup From 56020820a61b3da15247f0bf36fc732fe489c67b Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Sat, 8 Oct 2022 11:28:00 +0200 Subject: [PATCH 04/14] Action/Server/showFroms: document & upname a little --- src/Action/Server.hs | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/src/Action/Server.hs b/src/Action/Server.hs index 06f6ade7..0616e69b 100644 --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiWayIf #-} {-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE NamedFieldPuns #-} module Action.Server(actionServer, actionReplay, action_server_test_, action_server_test) where @@ -257,13 +258,21 @@ itemCategories xs = [("is","module") | any ((==) "module" . targetType) xs] ++ nubOrd [("package",p) | Just (p,_) <- map targetPackage xs] +-- | Display the line under the title of a search result, which contains a list of Modules each target is defined in, ordered by package. showFroms :: UrlOpts -> [Target] -> Markup -showFroms urlOpts xs = mconcat $ intersperse ", " $ flip map pkgs $ \p -> - let ms = filter ((==) p . targetPackage) xs - in mconcat $ intersperse " " [H.a ! H.href (H.stringValue $ showURL urlOpts b) $ H.string a | (a,b) <- catMaybes $ p : map remod ms] +showFroms urlOpts targets = mconcat $ intersperse ", " $ flip map pkgs $ \pkg -> + let ms = filter ((==) pkg . targetPackage) targets + in mconcat $ intersperse " " + [(H.a ! H.href (H.stringValue $ showURL urlOpts targetUrl)) + (H.string pkgName) + | (pkgName, targetUrl) + <- catMaybes $ pkg : map pkgAndTargetUrlMay ms + ] where - remod Target{..} = do (a,_) <- targetModule; pure (a,targetURL) - pkgs = nubOrd $ map targetPackage xs + pkgAndTargetUrlMay Target{targetModule, targetURL} = do + (pkgName, _) <- targetModule + pure (pkgName, targetURL) + pkgs = nubOrd $ map targetPackage targets showURL :: UrlOpts -> URL -> String showURL IsHaddockUrl x = "haddock/" ++ dropPrefix "file:///" x From 11739d300f26b59be22fe9acf90453ad07be3dec Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Sat, 8 Oct 2022 16:59:11 +0200 Subject: [PATCH 05/14] Action/Server/showResults: annotate functions in where --- src/Action/Server.hs | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/src/Action/Server.hs b/src/Action/Server.hs index 0616e69b..45145861 100644 --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -223,7 +223,7 @@ showResults urlOpts links args query results = do H.div ! H.class_ "doc newline shut" $ H.preEscapedString targetDocs H.ul ! H.id "left" $ do H.li $ H.b "Packages" - mconcat [H.li $ f cat val | (cat,val) <- itemCategories $ concat results, QueryScope True cat val `notElem` query] + mconcat [H.li $ leftSidebarSearchLinks cat val | (cat,val) <- itemCategories $ concat results, QueryScope True cat val `notElem` query] where useLink :: [Target] -> Maybe String @@ -231,14 +231,19 @@ showResults urlOpts links args query results = do Just $ "https://packdeps.haskellers.com/reverse/" ++ extractName (targetItem t) useLink _ = Nothing - add x = ("?" ++) $ intercalate "&" $ map (joinPair "=") $ + -- The search URL with an extra filter added to the hoogle query + searchURLWithExtraSearchFilter :: String -> String + searchURLWithExtraSearchFilter searchFilter = ("?" ++) $ intercalate "&" $ map (joinPair "=") $ case break ((==) "hoogle" . fst) args of - (a,[]) -> a ++ [("hoogle", escapeURL x)] - (a,(_,x1):b) -> a ++ [("hoogle", escapeURL $ x1 ++ " " ++ x)] ++ b - - f cat val = do - H.a ! H.class_" minus" ! H.href (H.stringValue $ add $ "-" ++ cat ++ ":" ++ val) $ "" - H.a ! H.class_ "plus" ! H.href (H.stringValue $ add $ cat ++ ":" ++ val) $ + (a,[]) -> a ++ [("hoogle", escapeURL searchFilter)] + (a,(_,x1):b) -> a ++ [("hoogle", escapeURL $ x1 ++ " " ++ searchFilter)] ++ b + + -- Construct two links in the left sidebar, + -- one which repeats the current search *with* the respective package or category, + -- one *without* the package or category. + leftSidebarSearchLinks cat val = do + H.a ! H.class_" minus" ! H.href (H.stringValue $ searchURLWithExtraSearchFilter $ "-" ++ cat ++ ":" ++ val) $ "" + H.a ! H.class_ "plus" ! H.href (H.stringValue $ searchURLWithExtraSearchFilter $ cat ++ ":" ++ val) $ H.string $ (if cat == "package" then "" else cat ++ ":") ++ val From 8b7663782c9a483aa1a950fa5830c54cd49fc155 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Sat, 8 Oct 2022 18:47:20 +0200 Subject: [PATCH 06/14] Action/Server/dedupeTake: rename to takeAndGroup & document The function does not really deduplicate the elements, it takes and groups. :) --- src/Action/Server.hs | 25 +++++++++++++++---------- 1 file changed, 15 insertions(+), 10 deletions(-) diff --git a/src/Action/Server.hs b/src/Action/Server.hs index 45145861..474031e5 100644 --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -115,7 +115,7 @@ replyServer log local links haddock store cdn home htmlDir scope Input{..} = cas | local -> IsLocalUrl | otherwise -> IsOtherUrl let body = showResults urlOpts links (filter ((/= "mode") . fst) inputArgs) q2 $ - dedupeTake 25 (\t -> t{targetURL="",targetPackage=Nothing, targetModule=Nothing}) results + takeAndGroup 25 (\t -> t{targetURL="",targetPackage=Nothing, targetModule=Nothing}) results case lookup "mode" inputArgs of Nothing | qSource /= [] -> fmap OutputHTML $ templateRender templateIndex [("tags", html $ tagOptions qScope) @@ -193,16 +193,21 @@ replyServer log local links haddock store cdn home htmlDir scope Input{..} = cas templateLogJs = templateFile (htmlDir "log.js") `templateApply` params -dedupeTake :: Ord k => Int -> (v -> k) -> [v] -> [[v]] -dedupeTake n key = f [] Map.empty +-- | Take from the list until we’ve seen `n` different keys, +-- and group all values by their respective key. +-- +-- Will keep the order of elements for each key the same. +takeAndGroup :: Ord k => Int -> (v -> k) -> [v] -> [[v]] +takeAndGroup n key = f [] Map.empty where - -- map is Map k [v] - f res mp [] - = map (reverse . (Map.!) mp) $ reverse res - f res mp _ | Map.size mp >= n - = map (reverse . (Map.!) mp) $ reverse res - f res mp (x:xs) | Just vs <- Map.lookup k mp = f res (Map.insert k (x:vs) mp) xs - | otherwise = f (k:res) (Map.insert k [x] mp) xs + -- mp is Map k [v] + f keys mp [] + = map (\k -> reverse $ mp Map.! k) $ reverse keys + f keys mp _ | Map.size mp >= n + = map (\k -> reverse $ mp Map.! k) $ reverse keys + f keys mp (x:xs) + | Just vs <- Map.lookup k mp = f keys (Map.insert k (x:vs) mp) xs + | otherwise = f (k:keys) (Map.insert k [x] mp) xs where k = key x data UrlOpts = IsHaddockUrl | IsLocalUrl | IsOtherUrl From 29f8eb1597484298224bf958c6ad4664df5fbca5 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Wed, 2 Nov 2022 16:00:19 +0100 Subject: [PATCH 07/14] Action/Server: Disable unwanted warnings MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Upstream does not think shadowing should be avoided, so let’s undo the changes to shadowing. Same with incomplete pattern warnings, we’ll just let it crash for now. Also drop the `Is*` prefix for the URL constructors. --- src/Action/Server.hs | 32 +++++++++++++++----------------- 1 file changed, 15 insertions(+), 17 deletions(-) diff --git a/src/Action/Server.hs b/src/Action/Server.hs index 474031e5..c4d3bbee 100644 --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ViewPatterns, TupleSections, RecordWildCards, ScopedTypeVariables, PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiWayIf #-} -{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wall -Wno-incomplete-patterns -Wno-name-shadowing #-} {-# LANGUAGE NamedFieldPuns #-} module Action.Server(actionServer, actionReplay, action_server_test_, action_server_test) where @@ -33,7 +33,7 @@ import System.Time.Extra import Data.Time.Clock import Data.Time.Calendar import System.IO.Unsafe -import Numeric.Extra hiding (log) +import Numeric.Extra import System.Info.Extra import Output.Tags @@ -48,7 +48,7 @@ import Action.Search import Action.CmdLine import Control.Applicative import Data.Monoid -import Prelude hiding (log) +import Prelude import qualified Data.Aeson as JSON @@ -65,10 +65,9 @@ actionServer cmd@Server{..} = do putStrLn . showDuration =<< time _ <- evaluate spawned dataDir <- maybe getDataDir pure datadir - haddock' <- maybe (pure Nothing) (fmap Just . canonicalizePath) haddock + haddock <- maybe (pure Nothing) (fmap Just . canonicalizePath) haddock withSearch database $ \store -> - server log cmd $ replyServer log local links haddock' store cdn home (dataDir "html") scope -actionServer _ = error "should not happen" + server log cmd $ replyServer log local links haddock store cdn home (dataDir "html") scope actionReplay :: CmdLine -> IO () actionReplay Replay{..} = withBuffering stdout NoBuffering $ do @@ -83,7 +82,6 @@ actionReplay Replay{..} = withBuffering stdout NoBuffering $ do evaluate $ rnf res putChar '.' putStrLn $ "\nTook " ++ showDuration t ++ " (" ++ showDuration (t / intToDouble (repeat_ * length qs)) ++ ")" -actionReplay _ = error "should not happen" {-# NOINLINE spawned #-} spawned :: UTCTime @@ -111,9 +109,9 @@ replyServer log local links haddock store cdn home htmlDir scope Input{..} = cas let (q2, results) = search store q let urlOpts = if - | Just _ <- haddock -> IsHaddockUrl - | local -> IsLocalUrl - | otherwise -> IsOtherUrl + | Just _ <- haddock -> HaddockUrl + | local -> LocalUrl + | otherwise -> OtherUrl let body = showResults urlOpts links (filter ((/= "mode") . fst) inputArgs) q2 $ takeAndGroup 25 (\t -> t{targetURL="",targetPackage=Nothing, targetModule=Nothing}) results case lookup "mode" inputArgs of @@ -154,8 +152,8 @@ replyServer log local links haddock store cdn home htmlDir scope Input{..} = cas ["log"] -> do OutputHTML <$> templateRender templateLog [] ["log.js"] -> do - log' <- displayLog <$> logSummary log - OutputJavascript <$> templateRender templateLogJs [("data",html $ H.preEscapedString log')] + log <- displayLog <$> logSummary log + OutputJavascript <$> templateRender templateLogJs [("data",html $ H.preEscapedString log)] ["stats"] -> do stats <- getStatsDebug pure $ case stats of @@ -210,7 +208,7 @@ takeAndGroup n key = f [] Map.empty | otherwise = f (k:keys) (Map.insert k [x] mp) xs where k = key x -data UrlOpts = IsHaddockUrl | IsLocalUrl | IsOtherUrl +data UrlOpts = HaddockUrl | LocalUrl | OtherUrl showResults :: UrlOpts -> Bool -> [(String, String)] -> [Query] -> [[Target]] -> Markup showResults urlOpts links args query results = do @@ -285,10 +283,10 @@ showFroms urlOpts targets = mconcat $ intersperse ", " $ flip map pkgs $ \pkg -> pkgs = nubOrd $ map targetPackage targets showURL :: UrlOpts -> URL -> String -showURL IsHaddockUrl x = "haddock/" ++ dropPrefix "file:///" x -showURL IsLocalUrl (stripPrefix "file:///" -> Just x) = "file/" ++ x -showURL IsLocalUrl x = x -showURL IsOtherUrl x = x +showURL HaddockUrl x = "haddock/" ++ dropPrefix "file:///" x +showURL LocalUrl (stripPrefix "file:///" -> Just x) = "file/" ++ x +showURL LocalUrl x = x +showURL OtherUrl x = x ------------------------------------------------------------- From efd152e0f69ad61e32dab69be37aac99d3cc4ed0 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Wed, 9 Nov 2022 16:14:19 +0100 Subject: [PATCH 08/14] Action/Server: remove -Wall again, to prevent -Werror killing CI CI unfortunately uses -Werror and tests against more modern versions of GHC, so any new errors will only appear on CI. --- src/Action/Server.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Action/Server.hs b/src/Action/Server.hs index c4d3bbee..cd093ff5 100644 --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -1,7 +1,6 @@ {-# LANGUAGE ViewPatterns, TupleSections, RecordWildCards, ScopedTypeVariables, PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiWayIf #-} -{-# OPTIONS_GHC -Wall -Wno-incomplete-patterns -Wno-name-shadowing #-} {-# LANGUAGE NamedFieldPuns #-} module Action.Server(actionServer, actionReplay, action_server_test_, action_server_test) where From e65973c02ce2f85727070be8b7558e44cfde54d5 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Sat, 8 Oct 2022 16:34:11 +0200 Subject: [PATCH 09/14] Action/Server/showFroms: split logic & template The way the template was filled was rather hard to follow. This tries to remedy it by splitting the code which infers the data from the list of targets, and the code which generates the HTML. The logic should be exactly the same, but we use a sort->groupBy to stable-sort Targets into their packages. --- src/Action/Server.hs | 47 ++++++++++++++++++++++++++++++++------------ 1 file changed, 34 insertions(+), 13 deletions(-) diff --git a/src/Action/Server.hs b/src/Action/Server.hs index cd093ff5..e626051c 100644 --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -50,6 +50,9 @@ import Data.Monoid import Prelude import qualified Data.Aeson as JSON +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.Traversable (for) actionServer :: CmdLine -> IO () actionServer cmd@Server{..} = do @@ -265,21 +268,39 @@ itemCategories xs = [("is","module") | any ((==) "module" . targetType) xs] ++ nubOrd [("package",p) | Just (p,_) <- map targetPackage xs] +-- | Return an alist [(PackageName, PackageUrl, [(TargetUrl, TargetModule)])] +showFromsLogic :: [Target] -> [(String, URL, [(URL, String)])] +showFromsLogic targets = do + targets + & sortOn targetPackage + & groupOn targetPackage + & mapMaybe genAssocList + where + genAssocList :: [Target] -> Maybe (String, URL, [(URL, String)]) + genAssocList targetGroup = do + -- all Targets in this targetGroup will have the same pkgName + -- due to the sort followed by the group + (pkgName, pkgUrl) <- targetGroup <&> targetPackage & headDef Nothing + targets' <- for targetGroup $ \Target{..} -> do + (moduleName, _) <- targetModule + pure (targetURL, moduleName) + pure (pkgName, pkgUrl, targets') + + -- | Display the line under the title of a search result, which contains a list of Modules each target is defined in, ordered by package. showFroms :: UrlOpts -> [Target] -> Markup -showFroms urlOpts targets = mconcat $ intersperse ", " $ flip map pkgs $ \pkg -> - let ms = filter ((==) pkg . targetPackage) targets - in mconcat $ intersperse " " - [(H.a ! H.href (H.stringValue $ showURL urlOpts targetUrl)) - (H.string pkgName) - | (pkgName, targetUrl) - <- catMaybes $ pkg : map pkgAndTargetUrlMay ms - ] - where - pkgAndTargetUrlMay Target{targetModule, targetURL} = do - (pkgName, _) <- targetModule - pure (pkgName, targetURL) - pkgs = nubOrd $ map targetPackage targets +showFroms urlOpts allTargets = do + let pkgs = showFromsLogic allTargets + mconcat $ intersperse ", " $ flip map pkgs $ \(pkgName, pkgUrl, targets) -> do + let link txt url = (H.a ! H.href (H.stringValue $ showURL urlOpts url)) (H.string txt) + mconcat $ intersperse " " + -- display the list as “pkg Module1 Module2", + -- each as links to either the package + -- or the target inside the respective module. + $ link pkgName pkgUrl + : [ link moduleName targetUrl + | (targetUrl, moduleName) <- targets + ] showURL :: UrlOpts -> URL -> String showURL HaddockUrl x = "haddock/" ++ dropPrefix "file:///" x From 275d9bbf2ee470c308edaa918c7328db180a1a0d Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Tue, 11 Oct 2022 12:52:58 +0200 Subject: [PATCH 10/14] Action/Server: reverse the order of modules in showFroms This will *not* change the top-link for the target to the first module, just switch around the displayed list. We need to push the logic out a bit further to change the top target. --- src/Action/Server.hs | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/src/Action/Server.hs b/src/Action/Server.hs index e626051c..46bbc405 100644 --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -298,9 +298,17 @@ showFroms urlOpts allTargets = do -- each as links to either the package -- or the target inside the respective module. $ link pkgName pkgUrl - : [ link moduleName targetUrl - | (targetUrl, moduleName) <- targets - ] + : + -- quite peculiarly, the list of modules inside each package + -- is sorted in reverse-topological order, that is downstream + -- modules are first in the result. We want the declaration module + -- to be first, so we reverse the ordering. + -- *Why* the list is in reverse topological order is not quite + -- clear to the authors, there is a good chance it’s accidental. + reverse + [ link moduleName targetUrl + | (targetUrl, moduleName) <- targets + ] showURL :: UrlOpts -> URL -> String showURL HaddockUrl x = "haddock/" ++ dropPrefix "file:///" x From 892f7c62abf9a8822fc2d8b9c1a987fa1f9ffe62 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Tue, 11 Oct 2022 13:15:36 +0200 Subject: [PATCH 11/14] Action/Server: let showsFromLogic return a struct --- src/Action/Server.hs | 26 ++++++++++++++++++-------- 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/src/Action/Server.hs b/src/Action/Server.hs index 46bbc405..94e543dc 100644 --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -268,36 +268,46 @@ itemCategories xs = [("is","module") | any ((==) "module" . targetType) xs] ++ nubOrd [("package",p) | Just (p,_) <- map targetPackage xs] + +-- | Data to display one search result +data ShowsFromData = ShowsFromData { + showsFromPackageName :: String, + showsFromPackageUrl :: URL, + -- | [(TargetUrl, TargetModule)] + showsFromModuleInfo :: [(URL, String)] + +} + -- | Return an alist [(PackageName, PackageUrl, [(TargetUrl, TargetModule)])] -showFromsLogic :: [Target] -> [(String, URL, [(URL, String)])] +showFromsLogic :: [Target] -> [ShowsFromData] showFromsLogic targets = do targets & sortOn targetPackage & groupOn targetPackage & mapMaybe genAssocList where - genAssocList :: [Target] -> Maybe (String, URL, [(URL, String)]) + genAssocList :: [Target] -> Maybe ShowsFromData genAssocList targetGroup = do -- all Targets in this targetGroup will have the same pkgName -- due to the sort followed by the group - (pkgName, pkgUrl) <- targetGroup <&> targetPackage & headDef Nothing - targets' <- for targetGroup $ \Target{..} -> do + (showsFromPackageName, showsFromPackageUrl) <- targetGroup <&> targetPackage & headDef Nothing + showsFromModuleInfo <- for targetGroup $ \Target{..} -> do (moduleName, _) <- targetModule pure (targetURL, moduleName) - pure (pkgName, pkgUrl, targets') + pure ShowsFromData {..} -- | Display the line under the title of a search result, which contains a list of Modules each target is defined in, ordered by package. showFroms :: UrlOpts -> [Target] -> Markup showFroms urlOpts allTargets = do let pkgs = showFromsLogic allTargets - mconcat $ intersperse ", " $ flip map pkgs $ \(pkgName, pkgUrl, targets) -> do + mconcat $ intersperse ", " $ flip map pkgs $ \ShowsFromData{..} -> do let link txt url = (H.a ! H.href (H.stringValue $ showURL urlOpts url)) (H.string txt) mconcat $ intersperse " " -- display the list as “pkg Module1 Module2", -- each as links to either the package -- or the target inside the respective module. - $ link pkgName pkgUrl + $ link showsFromPackageName showsFromPackageUrl : -- quite peculiarly, the list of modules inside each package -- is sorted in reverse-topological order, that is downstream @@ -307,7 +317,7 @@ showFroms urlOpts allTargets = do -- clear to the authors, there is a good chance it’s accidental. reverse [ link moduleName targetUrl - | (targetUrl, moduleName) <- targets + | (targetUrl, moduleName) <- showsFromModuleInfo ] showURL :: UrlOpts -> URL -> String From 2dc99fe74c4041defb1057cdbf28a38dc3b9794b Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Tue, 11 Oct 2022 14:37:18 +0200 Subject: [PATCH 12/14] Action/Server: Take the main search result link from reversed module Previously only the module list was reversed, but the main link to a search result would still point to the first module in the non-reversed list. This uses the logic for both the `showFroms` and the main result loop. Note that the order of *packages* is still pretty much arbitrary, so the user might still land in a package other than where the symbol was originally defined. But for example in the case of `find`, the `base` package is most often displayed first, and the `find` from `Data.Foldable` will now take precedence of the reexport from the reexport in `Data.List`. --- src/Action/Server.hs | 46 +++++++++++++++++++++++++------------------- 1 file changed, 26 insertions(+), 20 deletions(-) diff --git a/src/Action/Server.hs b/src/Action/Server.hs index 94e543dc..106a9707 100644 --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -216,15 +216,18 @@ showResults :: UrlOpts -> Bool -> [(String, String)] -> [Query] -> [[Target]] -> showResults urlOpts links args query results = do H.h1 $ renderQuery query when (null results) $ H.p "No results found" - forM_ results $ \is@(Target{..}:_) -> do + forM_ results $ \result -> do + let dat = showFromsLogic result + -- TODO: this crashes if there’s no targets + let Target{..} : _ = dat <&> showsFromFirstTarget H.div ! H.class_ "result" $ do H.div ! H.class_ "ans" $ do H.a ! H.href (H.stringValue $ showURL urlOpts targetURL) $ displayItem query targetItem when links $ - whenJust (useLink is) $ \link -> + whenJust (useLink result) $ \link -> H.div ! H.class_ "links" $ H.a ! H.href (H.stringValue link) $ "Uses" - H.div ! H.class_ "from" $ showFroms urlOpts is + H.div ! H.class_ "from" $ showFroms urlOpts dat H.div ! H.class_ "doc newline shut" $ H.preEscapedString targetDocs H.ul ! H.id "left" $ do H.li $ H.b "Packages" @@ -274,8 +277,9 @@ data ShowsFromData = ShowsFromData { showsFromPackageName :: String, showsFromPackageUrl :: URL, -- | [(TargetUrl, TargetModule)] - showsFromModuleInfo :: [(URL, String)] - + showsFromModuleInfo :: [(URL, String)], + -- | The full first target, used to display the actual target documentation. + showsFromFirstTarget :: Target } -- | Return an alist [(PackageName, PackageUrl, [(TargetUrl, TargetModule)])] @@ -284,13 +288,24 @@ showFromsLogic targets = do targets & sortOn targetPackage & groupOn targetPackage - & mapMaybe genAssocList + & mapMaybe + ( + genAssocList + -- quite peculiarly, the list of modules inside each package + -- is sorted in reverse-topological order, that is downstream + -- modules are first in the result. We want the declaration module + -- to be first, so we reverse the ordering. + -- *Why* the list is in reverse topological order is not quite + -- clear to the authors, there is a good chance it’s accidental. + . reverse + ) where genAssocList :: [Target] -> Maybe ShowsFromData genAssocList targetGroup = do -- all Targets in this targetGroup will have the same pkgName -- due to the sort followed by the group (showsFromPackageName, showsFromPackageUrl) <- targetGroup <&> targetPackage & headDef Nothing + showsFromFirstTarget <- listToMaybe targetGroup showsFromModuleInfo <- for targetGroup $ \Target{..} -> do (moduleName, _) <- targetModule pure (targetURL, moduleName) @@ -298,9 +313,8 @@ showFromsLogic targets = do -- | Display the line under the title of a search result, which contains a list of Modules each target is defined in, ordered by package. -showFroms :: UrlOpts -> [Target] -> Markup -showFroms urlOpts allTargets = do - let pkgs = showFromsLogic allTargets +showFroms :: UrlOpts -> [ShowsFromData] -> Markup +showFroms urlOpts pkgs = do mconcat $ intersperse ", " $ flip map pkgs $ \ShowsFromData{..} -> do let link txt url = (H.a ! H.href (H.stringValue $ showURL urlOpts url)) (H.string txt) mconcat $ intersperse " " @@ -308,17 +322,9 @@ showFroms urlOpts allTargets = do -- each as links to either the package -- or the target inside the respective module. $ link showsFromPackageName showsFromPackageUrl - : - -- quite peculiarly, the list of modules inside each package - -- is sorted in reverse-topological order, that is downstream - -- modules are first in the result. We want the declaration module - -- to be first, so we reverse the ordering. - -- *Why* the list is in reverse topological order is not quite - -- clear to the authors, there is a good chance it’s accidental. - reverse - [ link moduleName targetUrl - | (targetUrl, moduleName) <- showsFromModuleInfo - ] + : [ link moduleName targetUrl + | (targetUrl, moduleName) <- showsFromModuleInfo + ] showURL :: UrlOpts -> URL -> String showURL HaddockUrl x = "haddock/" ++ dropPrefix "file:///" x From 56dd792a5a7a24de5d601fc6e9b999132030b772 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Tue, 11 Oct 2022 15:09:00 +0200 Subject: [PATCH 13/14] Action/Server: Sort any leading `Internal` module to the back After reversing the module list, we have a pretty good topological order for modules, meaning the main link of a search result target (and the first module displayed) will usually be the definition of that target. There is however a convention to expose `.Internal` modules so that users can use unstable APIs if they have a need to. So in case the first module is such an `.Internal` module, we want to sort it back and display the next module in the list first. For example the result ``` toList :: IntSet -> [Key] containers Data.IntSet.Internal Data.IntSet ``` will now be displayed as ``` toList :: IntSet -> [Key] containers Data.IntSet Data.IntSet.Internal ``` and link to `Data.IntSet` by default. --- src/Action/Server.hs | 33 ++++++++++++++++++++++++++------- 1 file changed, 26 insertions(+), 7 deletions(-) diff --git a/src/Action/Server.hs b/src/Action/Server.hs index 106a9707..bfe84c44 100644 --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} module Action.Server(actionServer, actionReplay, action_server_test_, action_server_test) where @@ -53,6 +54,7 @@ import qualified Data.Aeson as JSON import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Traversable (for) +import Control.Category ((>>>)) actionServer :: CmdLine -> IO () actionServer cmd@Server{..} = do @@ -288,20 +290,37 @@ showFromsLogic targets = do targets & sortOn targetPackage & groupOn targetPackage - & mapMaybe - ( - genAssocList + & mapMaybe ( -- quite peculiarly, the list of modules inside each package -- is sorted in reverse-topological order, that is downstream -- modules are first in the result. We want the declaration module -- to be first, so we reverse the ordering. -- *Why* the list is in reverse topological order is not quite -- clear to the authors, there is a good chance it’s accidental. - . reverse - ) + reverse + >>> demoteInternalModule + >>> genShowsFromData + ) where - genAssocList :: [Target] -> Maybe ShowsFromData - genAssocList targetGroup = do + -- If the first Target has a module that ends on @".Internal"@, move it to second place. + -- This is a heuristic so that the main search result doesn’t open Internal modules by default. + -- + -- Ideally, we’d get the information of what is the “home module” for a target from haddock, + -- but for that we’ll need to parse the @.haddock@ binary file. So far we use the @.txt@ file + -- in the haddock output, which does not contain the home module information. + demoteInternalModule :: [Target] -> [Target] + demoteInternalModule + -- we can only think about targets with existing module field here, + -- because genAssocList filters out results where one+ modules contain an empty module name anyway. + (x@(targetModule -> Just (moduleName, _)) : y : xs) + | ".Internal" `isSuffixOf` moduleName + = y:x:xs + demoteInternalModule other = other + + -- This will throw away a result pretty strictly if any necessary information is missing, + -- for example the module name, the package name, etc. + genShowsFromData :: [Target] -> Maybe ShowsFromData + genShowsFromData targetGroup = do -- all Targets in this targetGroup will have the same pkgName -- due to the sort followed by the group (showsFromPackageName, showsFromPackageUrl) <- targetGroup <&> targetPackage & headDef Nothing From 4866a5b97c3a9579964cf977fcf3488677ced58d Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Tue, 11 Oct 2022 18:44:10 +0200 Subject: [PATCH 14/14] Action/Server: fall back to the original target for result Sometimes all targets in the target lists are filtered out by the mapMaybe in `showFromsLogic`, in that case we just fall back to the head of the original result. --- src/Action/Server.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/Action/Server.hs b/src/Action/Server.hs index bfe84c44..72bf759d 100644 --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -55,6 +55,8 @@ import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Traversable (for) import Control.Category ((>>>)) +import Data.List.NonEmpty (nonEmpty) +import qualified Data.List.NonEmpty as NonEmpty actionServer :: CmdLine -> IO () actionServer cmd@Server{..} = do @@ -220,8 +222,14 @@ showResults urlOpts links args query results = do when (null results) $ H.p "No results found" forM_ results $ \result -> do let dat = showFromsLogic result - -- TODO: this crashes if there’s no targets - let Target{..} : _ = dat <&> showsFromFirstTarget + let Target{..} = + ((dat <&> showsFromFirstTarget) + -- In case showsFromLogic filters out all targets because they are missing fields, + -- fall back to the original first target in the target list. + <|> result) + & nonEmpty & \case + Nothing -> error "showResults: The search result had an empty target list, this should not happen." + Just tgt -> NonEmpty.head tgt H.div ! H.class_ "result" $ do H.div ! H.class_ "ans" $ do H.a ! H.href (H.stringValue $ showURL urlOpts targetURL) $