Restore type-directed search (#1325)

Author: fsoikin

CHANGELOG.md

@@ -47,6 +47,7 @@ Other improvements:
   their specified dependency ranges.
 - `spago publish` no longer tries to validate all workspace dependencies, but
   only the (transitive) dependencies of the project being published.
+- Restored broken search-directed search in generated docs.
 
 ## [0.21.0] - 2023-05-04
 

core/src/Log.purs

@@ -77,6 +77,8 @@ data LogVerbosity
   | LogNormal
   | LogVerbose
 
+derive instance Eq LogVerbosity
+
 -- | LogVeryVerbose -- TODO:we'll need to add timestamps, and locations, see https://stackoverflow.com/questions/45395369/
 
 data LogLevel

docs-search/common/src/Docs/Search/TypeIndex.purs

@@ -7,14 +7,16 @@ module Docs.Search.TypeIndex
 
 import Prelude
 
+import Codec.JSON.DecodeError as DecodeError
 import Control.Promise (Promise, toAffE)
 import Data.Array as Array
+import Data.Bifunctor (lmap)
 import Data.Codec.JSON as CJ
-import Data.Either (hush)
+import Data.Either (Either(..))
 import Data.Foldable (fold, foldr)
 import Data.Map (Map)
 import Data.Map as Map
-import Data.Maybe (Maybe(..), fromMaybe')
+import Data.Maybe (Maybe(..))
 import Data.Newtype (class Newtype, over)
 import Data.Set (Set)
 import Docs.Search.Config as Config
@@ -27,6 +29,8 @@ import Docs.Search.TypeQuery (TypeQuery)
 import Docs.Search.TypeShape (shapeOfType, shapeOfTypeQuery, stringifyShape)
 import Effect (Effect)
 import Effect.Aff (Aff, try)
+import Effect.Aff as Error
+import Effect.Class.Console as Console
 import JSON (JSON)
 import Language.PureScript.Docs.Types (DocModule(..))
 import Registry.PackageName (PackageName)
@@ -80,15 +84,22 @@ lookup
   -> Aff { index :: TypeIndex, results :: Array SearchResult }
 lookup key index@(TypeIndex map) =
   case Map.lookup key map of
-    Just results -> pure { index, results: fold results }
+    Just results ->
+      pure { index, results: fold results }
     Nothing -> do
-      eiJson <- try (toAffE (lookup_ key $ Config.mkShapeScriptPath key))
-      pure $ fromMaybe'
-        (\_ -> { index: insert key Nothing index, results: [] })
-        do
-          json <- hush eiJson
-          results <- hush (CJ.decode (CJ.array SearchResult.searchResultCodec) json)
+      eitherJson <- try $ toAffE $ lookup_ key (Config.mkShapeScriptPath key)
+
+      let
+        eitherResults = do
+          json <- eitherJson # lmap Error.message
+          CJ.decode (CJ.array SearchResult.searchResultCodec) json # lmap DecodeError.print
+
+      case eitherResults of
+        Right results ->
           pure { index: insert key (Just results) index, results }
+        Left err -> do
+          Console.error $ "Error reading type index: " <> err
+          pure { index: insert key Nothing index, results: [] }
 
   where
   insert
@@ -102,9 +113,8 @@ query
   :: TypeIndex
   -> TypeQuery
   -> Aff { index :: TypeIndex, results :: Array SearchResult }
-query typeIndex typeQuery = do
-  res <- lookup (stringifyShape $ shapeOfTypeQuery typeQuery) typeIndex
-  pure $ res { results = res.results }
+query typeIndex typeQuery =
+  lookup (stringifyShape $ shapeOfTypeQuery typeQuery) typeIndex
 
 foreign import lookup_
   :: String

docs-search/index/src/Docs/Search/IndexBuilder.purs

@@ -51,15 +51,13 @@ import Docs.Search.Types (PartId)
 import Effect (Effect)
 import Effect.Aff (Aff, parallel, sequential)
 import Effect.Class (liftEffect)
-import Effect.Console (log)
 import JSON (JSON)
 import JSON as JSON
 import Node.Encoding (Encoding(UTF8))
 import Node.FS.Aff (mkdir, readFile, readTextFile, readdir, stat, writeFile, writeTextFile)
 import Node.FS.Stats (isDirectory, isFile)
 import Node.FS.Sync (exists)
 import Node.Path as Path
-import Node.Process as Process
 import Registry.Manifest (Manifest(..))
 import Registry.Manifest as Manifest
 import Registry.PackageName (PackageName)
@@ -72,15 +70,16 @@ type Config =
   , generatedDocs :: String
   , workspacePackages :: Set PackageName
   , moduleGraph :: Graph.ModuleGraphWithPackage
+  , log :: String -> Aff Unit
+  , die :: String -> Aff Unit
   }
 
 run :: Config -> Aff Unit
-run cfg = do
+run cfg@{ log } = do
 
   checkDirectories cfg
 
-  liftEffect do
-    log "Building the search index..."
+  log "Building the search index..."
 
   docsJsons /\ packageMetas <- sequential $
     Tuple
@@ -91,13 +90,12 @@ run cfg = do
     countOfPackages = Array.length packageMetas
     countOfModules = Array.length docsJsons
 
-  liftEffect do
-    log $
-      "Indexing "
-        <> show countOfModules
-        <> " modules from "
-        <> show countOfPackages
-        <> " packages..."
+  log $
+    "Indexing "
+      <> show countOfModules
+      <> " modules from "
+      <> show countOfPackages
+      <> " packages..."
 
   let
     scores = mkScores packageMetas
@@ -108,32 +106,28 @@ run cfg = do
 
   createDirectories cfg
 
-  void $ sequential do
-    ignore <$> parallel (writeIndex cfg index)
-      <*> parallel (writeTypeIndex typeIndex)
-      <*> parallel (writePackageInfo packageInfo)
-      <*> parallel (writeModuleIndex moduleIndex)
-      <*> parallel (patchDocs cfg)
-      <*> parallel (copyAppFile cfg)
+  sequential $
+    parallel (writeIndex cfg index)
+      *> parallel (writeTypeIndex typeIndex)
+      *> parallel (writePackageInfo packageInfo)
+      *> parallel (writeModuleIndex moduleIndex)
+      *> parallel (patchDocs cfg)
+      *> parallel (copyAppFile cfg)
 
   let
     countOfDefinitions = Trie.size $ unwrap index
     countOfTypeDefinitions =
       sum $ fromMaybe 0 <$> map Array.length <$> Map.values (unwrap typeIndex)
 
-  liftEffect do
-    log $
-      "Added "
-        <> show countOfDefinitions
-        <> " definitions and "
-        <> show countOfTypeDefinitions
-        <> " type definitions from "
-        <> show countOfPackages
-        <>
-          " packages to the search index."
-
-  where
-  ignore _ _ _ _ _ _ _ = unit
+  log $
+    "Added "
+      <> show countOfDefinitions
+      <> " definitions and "
+      <> show countOfTypeDefinitions
+      <> " type definitions from "
+      <> show countOfPackages
+      <>
+        " packages to the search index."
 
 -- | Exit early if something is missing.
 checkDirectories :: Config -> Aff Unit
@@ -147,23 +141,20 @@ checkDirectories cfg = do
 
   for_ dirs \dir -> do
     whenM (not <$> directoryExists dir) $
-      liftEffect do
-        logAndExit "Build the documentation first!"
+      cfg.die "Build the documentation first!"
 
 -- | Read and decode given `docs.json` files.
 decodeDocsJsons
-  :: forall rest
-   . { docsFiles :: Array String | rest }
+  :: ∀ rest
+   . { docsFiles :: Array String, log :: String -> Aff Unit, die :: String -> Aff Unit | rest }
   -> Aff (Array DocModule)
-decodeDocsJsons cfg@{ docsFiles } = do
+decodeDocsJsons cfg@{ docsFiles, log } = do
 
   paths <- getPathsByGlobs docsFiles
 
   when (Array.null paths) do
-    liftEffect do
-      logAndExit $
-        "The following globs do not match any files: " <> showGlobs cfg.docsFiles <>
-          ".\nBuild the documentation first!"
+    cfg.die $
+      "The following globs do not match any files: " <> showGlobs cfg.docsFiles <> ".\nBuild the documentation first!"
 
   docsJsons <- Array.catMaybes <$> for paths \jsonFile -> do
     doesExist <- fileExists jsonFile
@@ -179,38 +170,36 @@ decodeDocsJsons cfg@{ docsFiles } = do
 
       case eiResult of
         Left error -> do
-          liftEffect $ log $
-            "\"docs.json\" decoding failed failed for " <> jsonFile <> ": " <> error
+          log $ "\"docs.json\" decoding failed failed for " <> jsonFile <> ": " <> error
           pure Nothing
         Right result -> pure $ Just result
 
     else do
-      liftEffect $ do
-        log $
-          "File does not exist: " <> jsonFile
+      log $ "File does not exist: " <> jsonFile
       pure Nothing
 
   when (Array.null docsJsons) do
-    liftEffect $ logAndExit $
+    cfg.die $
       "Couldn't decode any of the files matched by the following globs: " <> showGlobs cfg.docsFiles
 
   pure docsJsons
 
-decodePursJsons :: forall rest. { pursJsonFiles :: Array String | rest } -> Aff (Array Manifest)
-decodePursJsons { pursJsonFiles } = do
+decodePursJsons
+  :: ∀ rest
+   . { pursJsonFiles :: Array String, log :: String -> Aff Unit, die :: String -> Aff Unit | rest }
+  -> Aff (Array Manifest)
+decodePursJsons cfg@{ pursJsonFiles } = do
   paths <- getPathsByGlobs pursJsonFiles
 
   when (Array.null paths) do
-    liftEffect do
-      logAndExit $
-        "The following globs do not match any files: " <> showGlobs pursJsonFiles <>
-          ".\nAre you in a project directory?"
-
+    cfg.die $
+      "The following globs do not match any files: " <> showGlobs pursJsonFiles <>
+        ".\nAre you in a project directory?"
   Array.nubBy compareNames
     <$> Array.catMaybes
     <$>
       for paths \jsonFileName ->
-        join <$> withExisting jsonFileName
+        join <$> withExisting cfg jsonFileName
           \contents ->
             either (logError jsonFileName) (pure <<< Just)
               ( JSON.parse contents >>=
@@ -224,24 +213,23 @@ decodePursJsons { pursJsonFiles } = do
     (Manifest { name: name2 }) = compare name1 name2
 
   logError fileName error = do
-    liftEffect $ log $
-      "\"purs.json\" decoding failed for " <> fileName <> ": " <> error
+    cfg.log $ "\"purs.json\" decoding failed for " <> fileName <> ": " <> error
     pure Nothing
 
 -- | Write type index parts to files.
 writeTypeIndex :: TypeIndex -> Aff Unit
 writeTypeIndex typeIndex =
   for_ entries \(Tuple typeShape results) -> do
     writeTextFile UTF8 (unwrap Config.typeIndexDirectory <> "/" <> typeShape <> ".js")
-      (mkHeader typeShape <> JSON.print (CJ.encode codec results))
+      (mkHeader typeShape <> JSON.print (CJ.encode codec $ fromMaybe [] results))
   where
   mkHeader typeShape =
     "// This file was generated by docs-search\n"
       <> "window.DocsSearchTypeIndex[\""
       <> typeShape
       <> "\"] = "
 
-  codec = CJ.Common.maybe $ CJ.array SearchResult.searchResultCodec
+  codec = CJ.array SearchResult.searchResultCodec
 
   entries :: Array _
   entries = Map.toUnfoldableUnordered (unwrap typeIndex)
@@ -350,18 +338,18 @@ patchDocs cfg = do
 -- | Create directories for two indices, or fail with a message
 -- | in case the docs were not generated.
 createDirectories :: Config -> Aff Unit
-createDirectories { generatedDocs } = do
+createDirectories { generatedDocs, die } = do
   let
     htmlDocs = Path.concat [ generatedDocs, "html" ]
     indexDir = Path.concat [ generatedDocs, "html", "index" ]
     declIndexDir = Path.concat [ generatedDocs, "html", "index", "declarations" ]
     typeIndexDir = Path.concat [ generatedDocs, "html", "index", "types" ]
 
-  whenM (not <$> directoryExists generatedDocs) $ liftEffect do
-    logAndExit "Generate the documentation first!"
+  whenM (not <$> directoryExists generatedDocs) $
+    die "Generate the documentation first!"
 
-  whenM (not <$> directoryExists htmlDocs) $ liftEffect do
-    logAndExit "Generate the documentation first!"
+  whenM (not <$> directoryExists htmlDocs) $
+    die "Generate the documentation first!"
 
   whenM (not <$> directoryExists indexDir) do
     mkdir indexDir
@@ -375,13 +363,13 @@ createDirectories { generatedDocs } = do
 -- | Copy the client-side application, responsible for handling user input and rendering
 -- | the results, to the destination path.
 copyAppFile :: Config -> Aff Unit
-copyAppFile { generatedDocs } = do
+copyAppFile { generatedDocs, die } = do
   appFile <- liftEffect getDocsSearchAppPath
-  whenM (not <$> fileExists appFile) do
-    liftEffect do
-      logAndExit $
-        "Client-side app was not found at " <> appFile <> ".\n" <>
-          "Check your installation."
+  unlessM (fileExists appFile)
+    $ die
+    $
+      "Client-side app was not found at " <> appFile <> ".\n" <>
+        "Check your installation."
   buffer <- readFile appFile
   writeFile (Path.concat [ generatedDocs, "html", "docs-search-app.js" ]) buffer
 
@@ -399,25 +387,18 @@ fileExists path = do
     false -> pure false
     true -> isFile <$> stat path
 
-withExisting :: forall a. String -> (String -> Aff a) -> Aff (Maybe a)
-withExisting file f = do
+withExisting :: ∀ a r. { log :: String -> Aff Unit | r } -> String -> (String -> Aff a) -> Aff (Maybe a)
+withExisting cfg file f = do
   doesExist <- fileExists file
 
   if doesExist then do
     contents <- readTextFile UTF8 file
     res <- f contents
     pure $ Just res
   else do
-    liftEffect $ do
-      log $
-        "File does not exist: " <> file
+    cfg.log $ "File does not exist: " <> file
     pure Nothing
 
-logAndExit :: forall a. String -> Effect a
-logAndExit message = do
-  log message
-  Process.exit' 1
-
 showGlobs :: Array String -> String
 showGlobs = Array.intercalate ", "