Action/Server refactors

src/Action/Server.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE ViewPatterns, TupleSections, RecordWildCards, ScopedTypeVariables, PatternGuards #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module Action.Server(actionServer, actionReplay, action_server_test_, action_server_test) where
 
@@ -60,7 +62,7 @@ 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
     withSearch database $ \store ->
@@ -88,24 +90,36 @@ 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
         let qSearch = grabBy (`elem` ["hoogle","q"])
         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 $
-                dedupeTake 25 (\t -> t{targetURL="",targetPackage=Nothing, targetModule=Nothing}) results
+
+        let urlOpts = if
+              | 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
             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" ->
@@ -130,7 +144,7 @@ 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"
 
@@ -144,8 +158,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)
@@ -161,72 +175,86 @@ 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
 
 
-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 xs | Map.size mp >= n || null xs = 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 = HaddockUrl | LocalUrl | OtherUrl
 
-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"
-        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
         useLink [t] | isNothing $ targetPackage t =
             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
 
 
 -- find the <span class=name>X</span> bit
 extractName :: String -> String
 extractName x
-    | Just (_, x) <- stripInfix "<span class=name>" x
-    , Just (x, _) <- stripInfix "</span>" x
-    = unHTML x
+    | Just (_, x') <- stripInfix "<span class=name>" x
+    , Just (x'', _) <- stripInfix "</span>" x'
+    = unHTML x''
 extractName x = x
 
 
@@ -237,35 +265,44 @@ 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 ->
-    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]
+-- | 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
-        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 :: 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 HaddockUrl x = "haddock/" ++ dropPrefix "file:///" x
+showURL LocalUrl (stripPrefix "file:///" -> Just x) = "file/" ++ x
+showURL LocalUrl x = x
+showURL OtherUrl x = x
 
 
 -------------------------------------------------------------
 -- DISPLAY AN ITEM (bold keywords etc)
 
 highlightItem :: [Query] -> String -> Markup
-highlightItem qs x
-    | Just (pre,x) <- stripInfix "<s0>" x, Just (name,post) <- stripInfix "</s0>" x
+highlightItem qs str
+    | Just (pre,x) <- stripInfix "<s0>" str, Just (name,post) <- stripInfix "</s0>" 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