From cf839b71b1c85893293840dc3ab70fd7dae3e72b Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Sat, 8 Oct 2022 10:21:21 +0200 Subject: [PATCH 1/9] 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 2/9] 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 3/9] 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 4/9] 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 5/9] 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 6/9] 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 7/9] 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 8/9] 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 9/9] 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