Display suggestions for unknown vertex

TODO: Don't suggest a single type; use it.

src/server/Server.hs

@@ -30,6 +30,8 @@ import Server.HtmlStream (HtmlStream)
 import qualified Data.FileEmbed
 import qualified Data.Text.Encoding
 import qualified Data.Text.Encoding.Error
+import qualified Data.List.NonEmpty as NE
+import Control.Monad (unless)
 
 main :: Server.Pages.Search.SearchConfig -> Html () -> Int -> FilePath -> IO ()
 main searchConfig appendToHead port graphDataFilename =
@@ -65,10 +67,13 @@ mkHandlers
   -> FunGraph.Graph ST.RealWorld
   -> IO Handlers
 mkHandlers searchConfig appendToHead graph = do
-  (typeaheadHandler, initalSuggestions) <-
+  unless (Server.Pages.Search.searchConfigSuggestionLimit searchConfig >= 1) $
+    fail "'searchConfigSuggestionLimit' must be greater than or equal to 1."
+  (typeaheadHandler, lookupFunction, initalSuggestions) <-
     Server.Pages.Typeahead.mkHandler (Just typeaheadCountLimit) graph
   let mkRootHandler = Server.Pages.Root.page (fixSvgWidth <> appendToHead <> bodyMargin) htmxScript initalSuggestions
-  searchEnv <- Server.Pages.Search.createSearchEnv mkRootHandler graph
+      lookupFunctionLimited = fmap (NE.fromList . NE.take (fromIntegral $ Server.Pages.Search.searchConfigSuggestionLimit searchConfig)) . lookupFunction
+  searchEnv <- Server.Pages.Search.createSearchEnv mkRootHandler graph lookupFunctionLimited
   pure $ Handlers
         (mkRootHandler (mempty, (Nothing, Nothing))) -- root handler
         (\mHxBoosted mSrc mDst mMaxCount mNoGraph -> do -- search handler

src/server/Server/Pages/Search.hs

@@ -35,7 +35,7 @@ import Control.Monad.Except (throwError)
 import Data.Maybe (fromMaybe, isNothing)
 import qualified Data.HashMap.Strict as HM
 import qualified Data.Graph.Digraph as DG
-import Server.Api (HxBoosted (HxBoosted), NoGraph (NoGraph))
+import Server.Api (HxBoosted (HxBoosted), NoGraph (NoGraph), Search)
 import Data.String (fromString)
 import qualified Data.ByteString.Lazy.Char8 as BSL
 import Data.Bifunctor (bimap)
@@ -47,13 +47,20 @@ import Control.Monad (when, forM)
 import qualified Data.Time.Clock
 import qualified Control.Monad.ST
 import Data.These (These (..))
+import qualified Data.List.NonEmpty as NE
+import Data.Functor ((<&>))
+import qualified Lucid.Servant
+import Data.Data (Proxy (Proxy))
+import qualified Server.Pages.Typeahead
 
 -- | Things we want to precompute when creating the handler
 data SearchEnv = SearchEnv
   { searchEnvGraph :: !(FunGraph.Graph ST.RealWorld)
-  , searchEnvVertexLookup :: T.Text -> Maybe FunGraph.FullyQualifiedType
-  , searchEnvRootHandler :: (HtmlStream IO (), (Maybe T.Text, Maybe T.Text)) -> HtmlStream IO ()
+  , searchEnvVertexLookup :: !(T.Text -> Maybe FunGraph.FullyQualifiedType)
+  , searchEnvRootHandler :: !((HtmlStream IO (), (Maybe T.Text, Maybe T.Text)) -> HtmlStream IO ())
     -- ^ Needed in case the 'HX-Boosted' header is not present, in which case a full page is returned
+  , searchEnvTypeSuggestion :: !(T.Text -> Maybe (NE.NonEmpty FunGraph.FullyQualifiedType))
+    -- ^ Find suggestions for the "no such vertex"-error
   }
 
 -- | Search options
@@ -63,25 +70,32 @@ data SearchConfig = SearchConfig
   -- Necessary because the worst case running time for a query is huge.
   , searchConfigTrace :: !(Maybe (String -> Control.Monad.ST.ST Control.Monad.ST.RealWorld ()))
   -- ^ Optionally print tracing information for each search query
+  , searchConfigSuggestionLimit :: !Word
+  -- ^ Display at most this many suggestions in the "no such vertex"-error message.
+  --
+  -- Must be greater than or equal to 1.
   }
 
 defaultSearchConfig :: SearchConfig
 defaultSearchConfig = SearchConfig
   { searchConfigTimeout = 0.1
   , searchConfigTrace = Nothing
+  , searchConfigSuggestionLimit = 10
   }
 
 createSearchEnv
   :: ((HtmlStream IO (), (Maybe T.Text, Maybe T.Text)) -> HtmlStream IO ())
   -> FunGraph.Graph ST.RealWorld
+  -> (T.Text -> Maybe (NE.NonEmpty FunGraph.FullyQualifiedType))
   -> IO SearchEnv
-createSearchEnv mkRootHandler graph = do
+createSearchEnv mkRootHandler graph typeSuggestion = do
   vertices <- ST.stToIO $ DG.vertexLabels graph
   let hm = HM.fromList $ map (\fqt -> (FunGraph.renderFullyQualifiedType fqt, fqt)) vertices
   pure $ SearchEnv
     { searchEnvGraph = graph
     , searchEnvVertexLookup = (`HM.lookup` hm)
     , searchEnvRootHandler = mkRootHandler
+    , searchEnvTypeSuggestion = typeSuggestion
     }
 
 -- ^ /Search/ handler type
@@ -97,9 +111,10 @@ type ValidationError =
   (These (InputFieldValidationError 'Src) (InputFieldValidationError 'Dst))
 
 renderHandlerError
-  :: These (InputFieldValidationError 'Src) (InputFieldValidationError 'Dst)
+  :: SearchEnv
+  -> These (InputFieldValidationError 'Src) (InputFieldValidationError 'Dst)
   -> Html ()
-renderHandlerError = \case
+renderHandlerError searchEnv = \case
   This err -> renderError "source" err
   That err -> renderError "target" err
   These errSrc errTgt -> do
@@ -110,13 +125,22 @@ renderHandlerError = \case
     renderError inputName = \case
       InputFieldValidationError_MissingVertex ->
         mkErrorText . toHtml $ "Missing " <> inputName <> " vertex"
-      InputFieldValidationError_NoSuchVertex input ->
-        mkErrorText $
-          mconcat $ intersperse (toHtml (" " :: T.Text))
-            [ toHtml $ "No such " <> inputName <> " vertex"
+      InputFieldValidationError_NoSuchVertex input mkHref ->
+        let mSuggestions = searchEnvTypeSuggestion searchEnv input
+            renderType fqt =
+              mkMonoText $ toHtml $ FunGraph.renderFullyQualifiedType fqt
+            mkSuggestion fqt =
+              li_ $ a_ [mkHref fqt] (renderType fqt)
+        in mkErrorText $
+          unwordsHtml $
+            [ toHtml $ "No exact match for " <> inputName <> " vertex"
             , mkMonoText (toHtml input) <> "."
-            , "Perhaps you meant one of: TODO"
-            ]
+            ] ++ fromMaybe []
+            ( mSuggestions <&> \suggestions ->
+                [ "Did you mean one of the following?"
+                , ul_ . mconcat $ map mkSuggestion (NE.toList suggestions)
+                ]
+            )
 
 -- | Full handler (considers 'HX-Boosted' header)
 handler
@@ -125,12 +149,12 @@ handler
   -> HandlerType (HtmlStream IO ())
 handler cfg searchEnv mHxBoosted mSrc mDst mMaxCount mNoGraph = do
   eResult <- handler' cfg searchEnv mHxBoosted mSrc mDst mMaxCount mNoGraph
-  let searchResultHtml = case eResult of -- either the actual result or a human-readable error
+  -- either the actual result or a human-readable error
+  let searchResultHtml = case eResult of
         Right searchResultStream ->
           searchResultStream
         Left err ->
-          Server.HtmlStream.streamHtml $ Server.Pages.Search.renderHandlerError err
-  -- pure $ eResult <&> \(_, (src, dst)) ->
+          Server.HtmlStream.streamHtml $ renderHandlerError searchEnv err
   pure $ case mHxBoosted of
     Just HxBoosted ->
       searchResultHtml
@@ -153,23 +177,33 @@ handler' cfg searchEnv _ mSrc mDst mMaxCount mNoGraph =
           (These (InputFieldValidationError 'Src) (InputFieldValidationError 'Dst))
             (FunGraph.FullyQualifiedType, FunGraph.FullyQualifiedType)
     validatedVertices =
-      case (validateVertex mSrc, validateVertex mDst) of
+      let render = Server.Pages.Typeahead.renderSearchValue
+          resSrc = validateVertex (\src -> mkHref' (Just $ render src) mDst) mSrc
+          resDst = validateVertex (\dst -> mkHref' mSrc (Just $ render dst)) mDst
+      in case (resSrc, resDst) of
         (Right src, Right dst) -> Right (src, dst)
         (Left err, Right _) -> Left $ This err
         (Right _, Left err) -> Left $ That err
         (Left err1, Left err2) -> Left $ These err1 err2
 
     validateVertex
-      :: Maybe T.Text
+      :: (FunGraph.FullyQualifiedType -> Attribute)
+      -> Maybe T.Text
       -> Either (InputFieldValidationError inputField) FunGraph.FullyQualifiedType
-    validateVertex Nothing = Left InputFieldValidationError_MissingVertex
-    validateVertex (Just txt) =
+    validateVertex _ Nothing = Left InputFieldValidationError_MissingVertex
+    validateVertex mkHref (Just txt) =
       let lookupVertex = searchEnvVertexLookup searchEnv
       in maybe
-        (Left $ InputFieldValidationError_NoSuchVertex txt)
+        (Left $ InputFieldValidationError_NoSuchVertex txt mkHref)
         Right
         (lookupVertex txt)
 
+    mkHref' :: Maybe T.Text -> Maybe T.Text -> Attribute -- src -> dst -> attr
+    mkHref' =
+      let api = Proxy :: Proxy Server.Api.Search
+          mkLink = Lucid.Servant.safeHref_ "/" api api
+      in \mSrc' mDst' -> mkLink mSrc' mDst' mMaxCount mNoGraph
+
 type StreamElem = ([FunGraph.NonEmpty FunGraph.TypedFunction], Double)
 
 page
@@ -351,6 +385,12 @@ mkMonoText =
         ]
   in span_ [style]
 
+unwordsHtml
+  :: [Html ()]
+  -> Html ()
+unwordsHtml =
+  mconcat . intersperse (toHtml (" " :: T.Text))
+
 -- | Exported for benchmarking purposes: marks the actual results in the HTML so we can benchmark e.g. "time to first result"
 mkResultAttribute :: T.Text -> Attribute
 mkResultAttribute = data_ "result-number"
@@ -389,4 +429,8 @@ data VertexInputField
 
 data InputFieldValidationError (inputField :: VertexInputField)
   = InputFieldValidationError_MissingVertex
-  | InputFieldValidationError_NoSuchVertex T.Text
+  | InputFieldValidationError_NoSuchVertex
+      T.Text
+      -- ^ the unknown vertex name
+      (FunGraph.FullyQualifiedType -> Attribute)
+      -- ^ construct a link (as an 'href' attribute) to the /search page from a suggestion

src/server/Server/Pages/Typeahead.hs

@@ -33,15 +33,20 @@ type HandlerType
   -> Maybe T.Text
   -> Handler (Html ())
 
+-- | Used to look up suggestions for the "no such vertex"-error
+type LookupFunction
+  = T.Text -> Maybe (NE.NonEmpty FunGraph.FullyQualifiedType)
+
 mkHandler
   :: Maybe Word -- ^ Limit the number of typeahead suggestions. NB: Must be greater than zero if present.
   -> FunGraph.Graph ST.RealWorld
-  -> IO ( HandlerType, Html ()) -- ^ (handler, initial suggestions)
+  -> IO (HandlerType, LookupFunction, Html ()) -- ^ (handler, initial suggestions)
 mkHandler mLimit graph = do
   mPrioTrie <- mkPrioTrie mLimit graph
   prioTrie <- maybe (fail "empty input graph in Typeahead handler") pure mPrioTrie
   let initialSuggestions = suggestions prioTrie ""
-  pure (handler prioTrie, initialSuggestions)
+      lookupFunction prefix = fmap snd <$> Data.PrioTrie.prefixLookup prioTrie (TE.encodeUtf8 prefix)
+  pure (handler prioTrie, lookupFunction, initialSuggestions)
 
 -- | For each vertex (type), count the number of different packages that export a function which operates on this vertex (type).
 calculatePriorities