added: CLI interface; added: search REPL (#5)

* added: CLI interface
added: search REPL

* added: shebang to the executable file

* added: automatic deployments

* better heuristics for package name detection

* added: previews

.gitignore

@@ -8,3 +8,4 @@
 /.purs*
 /.psa*
 /.spago/
+/dist/

.travis.yml

@@ -19,24 +19,31 @@ install:
 - tar -xvf $HOME/purescript.tar.gz -C $HOME/
 - chmod a+x $HOME/purescript
 - npm install -g spago
+- npm install
 - spago install
 
 script:
 - spago build
 - spago test
 - spago docs
-- spago bundle-app -m Docs.Search.App --to docs-search-app.js
+- npm run build
-- spago bundle-app -m Docs.Search.IndexBuilder --to index-builder.js
+- node dist/main.js build-index
-- node index-builder.js
 
 deploy:
   - provider: releases
     api_key: $API_KEY
     file:
-      - docs-search-app.js
+      - dist/docs-search-app.js
-      - index-builder.js
+      - dist/main.js
     skip_cleanup: true
     on:
       tags: true
     script:
       - echo 'done'
+  - provider: npm
+    api_key: $NPM_API_KEY
+    email: klntsky@gmail.com
+    skip_cleanup: true
+    on:
+      tags: true
+      branch: master

README.md

@@ -4,21 +4,34 @@
 
 An app that adds search capabilities to generated documentation for purescript code.
 
-The goal is to replicate all functionality of pursuit, including querying by type.
+It supports nearly-all functionality of [Pursuit](https://github.com/purescript/pursuit), including querying by type.
 
-See [#89](https://github.com/spacchetti/spago/issues/89).
+## Installing
 
-To see it in action, run the following:
+Run `npm install purescript-docs-search`.
 
-```
+## Usage
-spago build
-spago docs
-spago bundle-app -m Docs.Search.App --to generated-docs/docs-search-app.js
-spago run -m Docs.Search.IndexBuilder
-```
 
-## UI
+There are two usage scenarios:
+
+### Patching static documentation
+
+Use `purescript-docs-search build-index` command to patch HTML files located in `generated-docs/html`. You then will be able to search for declarations or types:
+
+![Preview](preview.png)
 
 The user interface of the app is optimised for keyboard-only use.
 
 **S** hotkey can be used to focus on the search field, **Escape** can be used to leave it. Pressing **Escape** twice will close the search results listing.
+
+### Using the CLI
+
+Running `purescript-docs-search` within a project directory will open an interactive command-line session.
+
+Note that unlike in Pursuit, most relevant results will appear last.
+
+A quick demo:
+
+[![asciicast](https://asciinema.org/a/Hexie5JoWjlAqLqv2IgafIdb9.svg)](https://asciinema.org/a/Hexie5JoWjlAqLqv2IgafIdb9)
+
+You may notice that the CLI offers slightly better results than the web interface. This is a performance tradeoff.

package.json

@@ -0,0 +1,43 @@
+{
+  "name": "purescript-docs-search",
+  "version": "0.0.1",
+  "description": "Search frontend for the documentation generated by the PureScript compiler.",
+  "main": "dist/main.js",
+  "directories": {
+    "test": "test"
+  },
+  "bin": {
+    "purescript-docs-search": "dist/main.js"
+  },
+  "files": [
+    "dist/main.js",
+    "dist/docs-search-app.js",
+    "README.md"
+  ],
+  "scripts": {
+    "test": "spago test",
+    "bundle-app": "spago bundle-app -m Docs.Search.App --to dist/docs-search-app.js",
+    "bundle-main": "spago bundle-app -m Docs.Search.Main --to dist/main.js && browserify --no-builtins --no-commondir --no-detect-globals --node dist/main.js --outfile dist/main-bundled.js && echo \"#!/usr/bin/env node\" > dist/main.js && cat dist/main-bundled.js >> dist/main.js && rm dist/main-bundled.js",
+    "build": "npm run bundle-app && npm run bundle-main",
+    "clean": "rm -rf dist"
+  },
+  "repository": {
+    "type": "git",
+    "url": "git+https://github.com/spacchetti/purescript-docs-search.git"
+  },
+  "keywords": [
+    "purescript"
+  ],
+  "author": "Kalnitsky Vladimir <klntsky@gmail.com>",
+  "license": "BSD-3-Clause",
+  "bugs": {
+    "url": "https://github.com/spacchetti/purescript-docs-search/issues"
+  },
+  "homepage": "https://github.com/spacchetti/purescript-docs-search#readme",
+  "dependencies": {},
+  "devDependencies": {
+    "browserify": "^16.3.0",
+    "glob": "^7.1.4",
+    "spago": "^0.8.5"
+  }
+}

packages.dhall

@@ -47,6 +47,28 @@ let additions =
 		  [ "css", "halogen" ]
 		  "https://github.com/slamdata/purescript-halogen-css.git"
 		  "v8.0.0"
+	  , optparse =
+		  mkPackage
+		  [ "prelude"
+		  , "effect"
+		  , "exitcodes"
+		  , "strings"
+		  , "ordered-collections"
+		  , "arrays"
+		  , "console"
+		  , "memoize"
+		  , "transformers"
+		  , "exists"
+		  , "node-process"
+		  , "free"
+		  ]
+		  "https://github.com/f-o-a-m/purescript-optparse.git"
+		  "v3.0.1"
+	  , exitcodes =
+		  mkPackage
+		  [ "enums" ]
+		  "https://github.com/Risto-Stevcev/purescript-exitcodes.git"
+		  "v4.0.0"
 	  }
 
 in  upstream ⫽ overrides ⫽ additions

spago.dhall

@@ -21,6 +21,8 @@
 	, "node-fs"
 	, "node-fs-aff"
 	, "node-process"
+	, "node-readline"
+	, "optparse"
 	, "profunctor"
 	, "search-trie"
 	, "string-parsers"

src/Docs/Search/App/SearchResults.purs

@@ -7,24 +7,19 @@ import Docs.Search.Config (config)
 import Docs.Search.Declarations (DeclLevel(..), declLevelToHashAnchor)
 import Docs.Search.DocsJson (DataDeclType(..))
 import Docs.Search.Extra ((>#>))
-import Docs.Search.Index (Index)
+import Docs.Search.SearchResult (ResultInfo(..), SearchResult)
-import Docs.Search.Index as Index
-import Docs.Search.SearchResult (ResultInfo(..), SearchResult, typeOf)
 import Docs.Search.TypeDecoder (Constraint(..), FunDep(..), FunDeps(..), Kind(..), QualifiedName(..), Type(..), TypeArgument(..), joinForAlls, joinRows)
-import Docs.Search.TypeIndex (TypeIndex)
+import Docs.Search.Engine as SearchEngine
-import Docs.Search.TypeIndex as TypeIndex
+import Docs.Search.Engine (ResultsType(..))
-import Docs.Search.TypeQuery (TypeQuery(..), parseTypeQuery, penalty)
 
 import CSS (textWhitespace, whitespacePreWrap)
 import Data.Array ((!!))
 import Data.Array as Array
-import Data.Either (hush)
 import Data.List as List
-import Data.Maybe (Maybe(..), isJust, maybe)
+import Data.Maybe (Maybe(..), isJust)
 import Data.Newtype (unwrap, wrap)
-import Data.String (length) as String
 import Data.String.CodeUnits (stripSuffix) as String
-import Data.String.Common (toLower, trim) as String
+import Data.String.Common (null, trim) as String
 import Data.String.Pattern (Pattern(..)) as String
 import Effect.Aff (Aff)
 import Halogen as H
@@ -38,15 +33,11 @@ import Web.HTML as HTML
 import Web.HTML.Location as Location
 import Web.HTML.Window as Window
 
-data Mode = Off | Loading | Active | InputTooShort
+data Mode = Off | Loading | Active
 
 derive instance eqMode :: Eq Mode
 
--- | Is it a search by type or by name?
+type State = { searchEngineState :: SearchEngine.State
-data ResultsType = TypeResults TypeQuery | DeclResults
-
-type State = { index :: Index
-             , typeIndex :: TypeIndex
              , results :: Array SearchResult
              , resultsType :: ResultsType
              , input :: String
@@ -68,8 +59,7 @@ mkComponent
   -> H.Component HH.HTML Query i o Aff
 mkComponent contents =
   H.mkComponent
-    { initialState: const { index: mempty
+    { initialState: const { searchEngineState: mempty
-                          , typeIndex: mempty
                           , results: []
                           , resultsType: DeclResults
                           , input: ""
@@ -99,36 +89,20 @@ handleQuery (MessageFromSearchField (InputUpdated input_) next) = do
 
   state <- H.modify (_ { input = input })
 
-  if String.length input < 2
+  if String.null input
   then do
-    if input == ""
-    then do
       H.modify_ (_ { mode = Off })
       showPageContents
-    else do
-      H.modify_ (_ { mode = InputTooShort })
-      hidePageContents
   else do
     H.modify_ (_ { mode = Loading, resultsCount = config.resultsCount })
 
     void $ H.fork do
-      let resultsType =
+      { searchEngineState, results, resultsType } <- H.liftAff $
-            maybe DeclResults TypeResults (hush (parseTypeQuery state.input)
+        SearchEngine.query state.searchEngineState state.input
-                                           >>= isValuableTypeQuery)
+      H.modify_ (_ { results = results
-
+                   , mode = Active
-      case resultsType of
+                   , searchEngineState = searchEngineState
-
+                   , resultsType = resultsType })
-        DeclResults -> do
-          { index, results } <- H.liftAff $ Index.query state.index (String.toLower state.input)
-          H.modify_ (_ { results = results
-                       , mode = Active
-                       , index = index })
-
-        TypeResults query -> do
-          { index, results } <- H.liftAff $ TypeIndex.query state.typeIndex query
-          H.modify_ (_ { results = sortByDistance query results
-                       , mode = Active
-                       , typeIndex = index })
 
     hidePageContents
 
@@ -181,12 +155,6 @@ render { mode: Off } = HH.div_ []
 render { mode: Loading } =
   renderContainer $
   [ HH.h1_ [ HH.text "Loading..." ] ]
-render { mode: InputTooShort } =
-  renderContainer $
-  [ HH.h1_ [ HH.text "Error" ] ] <>
-  [ HH.div [ HP.classes [ wrap "result", wrap "result--empty" ] ]
-    [ HH.text "Search query is too short." ]
-  ]
 render state@{ mode: Active, results: [] } =
   renderContainer $
 
@@ -299,11 +267,7 @@ renderResultType
 renderResultType result =
   case result.info of
     ValueResult { type: ty } ->
-      wrapSignature [ HH.a [ makeHref ValueLevel false result.moduleName result.name
+      wrapSignature $ renderValueSignature result ty
-                           , HE.onClick $ const $ Just $ SearchResultClicked result.moduleName ]
-                      [ HH.text result.name ]
-                    , HH.text " :: "
-                    , renderType ty ]
 
     TypeClassResult info ->
       wrapSignature $ renderTypeClassSignature info result
@@ -321,6 +285,21 @@ renderResultType result =
     wrapSignature signature =
       [ HH.pre [ HP.class_ (wrap "result__signature") ] [ HH.code_ signature ] ]
 
+renderValueSignature
+  :: forall a rest
+  .  { moduleName :: String
+     , name :: String
+     | rest
+     }
+  -> Type
+  -> Array (HH.HTML a Action)
+renderValueSignature result ty =
+  [ HH.a [ makeHref ValueLevel false result.moduleName result.name
+         , HE.onClick $ const $ Just $ SearchResultClicked result.moduleName ]
+    [ HH.text result.name ]
+  , HH.text " :: "
+  , renderType ty ]
+
 renderTypeClassSignature
   :: forall a rest
   .  { fundeps :: FunDeps
@@ -582,8 +561,8 @@ renderQualifiedName isInfix level (QualifiedName { moduleName, name })
 
 renderKind
   :: forall a
-  .  Kind ->
+  .  Kind
-  HH.HTML a Action
+  -> HH.HTML a Action
 renderKind = case _ of
   Row k1          -> HH.span_ [ HH.text "# ", renderKind k1 ]
   FunKind k1 k2   -> HH.span_ [ renderKind k1, syntax " -> ", renderKind k2 ]
@@ -616,17 +595,3 @@ syntax str = HH.span [ HP.class_ (wrap "syntax") ] [ HH.text str ]
 
 space :: forall a b. HH.HTML a b
 space = HH.text " "
-
-isValuableTypeQuery :: TypeQuery -> Maybe TypeQuery
-isValuableTypeQuery (QVar _) = Nothing
-isValuableTypeQuery (QConst _) = Nothing
-isValuableTypeQuery query = Just query
-
-sortByDistance :: TypeQuery -> Array SearchResult -> Array SearchResult
-sortByDistance typeQuery results =
-  _.result <$> Array.sortBy comparePenalties resultsWithPenalties
-  where
-    comparePenalties r1 r2 = compare r1.penalty r2.penalty
-    resultsWithPenalties = results <#>
-               \result -> { penalty: typeOf (unwrap result).info <#> penalty typeQuery
-                          , result }

src/Docs/Search/Config.purs

@@ -17,19 +17,20 @@ config =
   , numberOfIndexParts: 50
   -- ^ In how many parts the index should be splitted?
   , mkIndexPartPath:
-    \(partId :: Int) -> "generated-docs/index/declarations/" <> show partId <> ".js"
+    \(partId :: Int) -> "/index/declarations/" <> show partId <> ".js"
   , mkIndexPartLoadPath:
     \(partId :: Int) -> "../index/declarations/" <> show partId <> ".js"
   , resultsCount: 25
   -- ^ How many results to show by default?
-  , penalties: { typeVars: 6
+  , penalties: { typeVars: 2
                , match: 2
                , matchConstraint: 1
-               , instantiate: 1
+               , instantiate: 2
-               , generalize: 4
+               , generalize: 2
-               , rowsMismatch: 6
+               , rowsMismatch: 3
-               , mismatch: 10
                , missingConstraint: 1
                , excessiveConstraint: 1
                }
+  -- ^ Penalties used to determine how "far" a type query is from a given type.
+  -- See Docs.Search.TypeQuery
   }

src/Docs/Search/Declarations.purs

@@ -8,6 +8,7 @@ import Docs.Search.TypeDecoder (Constraint(..), QualifiedName(..), Type(..), joi
 
 import Control.Alt ((<|>))
 import Data.Array ((!!))
+import Data.Array as Array
 import Data.Foldable (foldr)
 import Data.List (List, (:))
 import Data.List as List
@@ -15,8 +16,8 @@ import Data.Maybe (Maybe(..), fromMaybe)
 import Data.Newtype (class Newtype, unwrap, wrap)
 import Data.Search.Trie (Trie, alter)
 import Data.String.CodeUnits (stripPrefix, stripSuffix, toCharArray)
-import Data.String.Common (toLower)
 import Data.String.Common (split) as String
+import Data.String.Common (toLower)
 import Data.String.Pattern (Pattern(..))
 
 type ModuleName = String
@@ -178,11 +179,18 @@ extractPackageName name =
   let chunks = String.split (Pattern "/") name in
   fromMaybe "<unknown>" $
   chunks !! 0 >>= \dir ->
-  -- TODO: is it safe to assume that directory name is ".spago"?
   if dir == ".spago" then
     chunks !! 1
   else
-    Just "<local package>"
+    let
+      bowerComponentsIndex =
+        Array.findIndex (_ == "bower_components") chunks
+    in
+      case bowerComponentsIndex of
+        Just n ->
+          chunks !! (n + 1)
+        Nothing ->
+          Just "<local package>"
 
 resultsForChildDeclaration
   :: PackageName

src/Docs/Search/DocsJson.purs

@@ -2,10 +2,9 @@ module Docs.Search.DocsJson where
 
 import Prelude
 
-import Docs.Search.TypeDecoder
+import Docs.Search.TypeDecoder (Constraint, FunDeps, Kind, Type, TypeArgument)
 
-import Control.Promise (Promise, toAffE)
+import Data.Argonaut.Core (fromString, stringify, toString)
-import Data.Argonaut.Core (Json, fromString, stringify, toString)
 import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.:), (.:?))
 import Data.Argonaut.Encode (class EncodeJson, encodeJson)
 import Data.Either (Either(..))
@@ -13,8 +12,6 @@ import Data.Generic.Rep (class Generic)
 import Data.Generic.Rep.Show (genericShow)
 import Data.Maybe (Maybe(..))
 import Data.Newtype (class Newtype, unwrap)
-import Effect (Effect)
-import Effect.Aff (Aff)
 
 newtype DocsJson
   = DocsJson { name :: String

src/Docs/Search/Engine.purs

@@ -0,0 +1,59 @@
+module Docs.Search.Engine where
+
+import Prelude
+
+import Docs.Search.TypeQuery (TypeQuery(..), parseTypeQuery, penalty)
+import Docs.Search.SearchResult (SearchResult, typeOf)
+import Docs.Search.Index as Index
+import Docs.Search.Index (Index)
+import Docs.Search.TypeIndex as TypeIndex
+import Docs.Search.TypeIndex (TypeIndex)
+
+import Data.Array as Array
+import Data.Either (hush)
+import Data.Maybe (Maybe(..))
+import Data.Newtype (unwrap)
+import Data.String.Common as String
+import Effect.Aff (Aff)
+
+data ResultsType = TypeResults TypeQuery | DeclResults
+
+type State = { index :: Index
+             , typeIndex :: TypeIndex
+             }
+
+query
+  :: State
+  -> String
+  -> Aff { searchEngineState :: State
+         , results :: Array SearchResult
+         , resultsType :: ResultsType
+         }
+query { index, typeIndex } input =
+  case hush (parseTypeQuery input) >>= isValuableTypeQuery of
+    Nothing -> do
+      response <- Index.query index (String.toLower input)
+      pure { searchEngineState: { index: response.index, typeIndex }
+           , results: response.results
+           , resultsType: DeclResults }
+
+    Just typeQuery -> do
+      response <- TypeIndex.query typeIndex typeQuery
+      pure { searchEngineState: { index, typeIndex: response.typeIndex }
+           , results: sortByDistance typeQuery response.results
+           , resultsType: TypeResults typeQuery }
+
+isValuableTypeQuery :: TypeQuery -> Maybe TypeQuery
+isValuableTypeQuery (QVar _) = Nothing
+isValuableTypeQuery (QConst _) = Nothing
+isValuableTypeQuery other = Just other
+
+sortByDistance :: TypeQuery -> Array SearchResult -> Array SearchResult
+sortByDistance typeQuery results =
+  _.result <$> Array.sortBy comparePenalties resultsWithPenalties
+  where
+    comparePenalties r1 r2 = compare r1.penalty r2.penalty
+    resultsWithPenalties =
+      results <#>
+      \result -> { penalty: typeOf (unwrap result).info <#> penalty typeQuery
+                 , result }

src/Docs/Search/Extra.js

@@ -0,0 +1,9 @@
+/* global exports require */
+
+var glob = require('glob');
+
+exports.glob = function (pattern) {
+  return function () {
+    return glob.sync(pattern);
+  };
+};

src/Docs/Search/Extra.purs

@@ -2,8 +2,12 @@ module Docs.Search.Extra where
 
 import Prelude
 
-import Data.Foldable (class Foldable, foldMap)
+import Data.Foldable (class Foldable, foldMap, foldl)
+import Data.List.NonEmpty (NonEmptyList, cons', uncons)
 import Data.Maybe (Maybe(..))
+import Effect (Effect)
+import Data.List as List
+import Data.List ((:))
 
 whenJust :: forall a m. Monad m => Maybe a -> (a -> m Unit) -> m Unit
 whenJust (Just a) f = f a
@@ -13,3 +17,19 @@ foldMapFlipped :: forall a m f. Foldable f => Monoid m =>  f a -> (a -> m) -> m
 foldMapFlipped = flip foldMap
 
 infixr 7 foldMapFlipped as >#>
+
+foreign import glob :: String -> Effect (Array String)
+
+foldl1 :: forall a. (a -> a -> a) -> NonEmptyList a -> a
+foldl1 f as =
+  case uncons as of
+    { head, tail } -> foldl f head tail
+
+foldr1 :: forall a. (a -> a -> a) -> NonEmptyList a -> a
+foldr1 f = go List.Nil
+  where
+    go acc x = case uncons x of
+      { head, tail } -> case List.uncons tail of
+        Nothing -> List.foldl (flip f) head acc
+        Just { head: head1, tail: tail1 } ->
+          go (head : acc) (cons' head1 tail1)

src/Docs/Search/Index.purs

@@ -98,6 +98,7 @@ getPartId (a : _) =
   Char.toCharCode a `mod` config.numberOfIndexParts
 getPartId _ = 0
 
+-- | Load a part of the index by injecting a <script> tag into the DOM.
 foreign import loadIndex_
  :: Int
  -> String

src/Docs/Search/IndexBuilder.js

@@ -0,0 +1,7 @@
+/* global __dirname require exports */
+
+var path = require('path');
+
+exports.getDirname = function () {
+  return __dirname;
+};

src/Docs/Search/IndexBuilder.purs

@@ -5,7 +5,7 @@ import Prelude
 import Docs.Search.Config (config)
 import Docs.Search.Declarations (Declarations(..), mkDeclarations)
 import Docs.Search.DocsJson (DocsJson)
-import Docs.Search.Extra ((>#>))
+import Docs.Search.Extra ((>#>), glob)
 import Docs.Search.Index (getPartId)
 import Docs.Search.SearchResult (SearchResult)
 import Docs.Search.TypeIndex (TypeIndex, mkTypeIndex)
@@ -35,55 +35,83 @@ import Effect.Aff (Aff, launchAff_, parallel, sequential)
 import Effect.Class (liftEffect)
 import Effect.Console (log)
 import Node.Encoding (Encoding(UTF8))
-import Node.FS.Aff (exists, mkdir, readTextFile, readdir, stat, writeTextFile)
+import Node.FS.Aff (exists, mkdir, readFile, readTextFile, readdir, stat, writeFile, writeTextFile)
 import Node.FS.Stats (isDirectory, isFile)
 import Node.Process as Process
 
-main :: Effect Unit
+type Config = { docsFiles :: Array String
-main = launchAff_ mainAff
+              , generatedDocs :: String
+              }
 
-mainAff :: Aff Unit
+run :: Config -> Effect Unit
-mainAff = do
+run = launchAff_ <<< run'
-  checkDirectories
 
-  docsJsons <- collectDocsJsons config.outputDirectory
+run' :: Config -> Aff Unit
+run' cfg = do
 
-  liftEffect $ log $
+  checkDirectories cfg
-    "Found " <> show (Array.length docsJsons) <> " modules."
+
+  liftEffect do
+    log "Building the search index..."
+
+  docsJsons <- decodeDocsJsons cfg
+
+  liftEffect do
+    log $ "Found " <> show (Array.length docsJsons) <> " modules."
 
   let index = mkDeclarations docsJsons
       typeIndex = mkTypeIndex index
 
-  createDirectories
+  createDirectories cfg
 
   void $ sequential do
-    ignore <$> parallel (writeIndex index)
+    ignore <$> parallel (writeIndex cfg index)
-           <*> parallel (writeTypeIndex typeIndex)
+           <*> parallel (writeTypeIndex cfg typeIndex)
-           <*> parallel patchDocs
+           <*> parallel (patchDocs cfg)
+           <*> parallel (copyAppFile cfg)
 
-  liftEffect $ log $
+  liftEffect do
-    "Loaded " <>
+    log $
-    show (Trie.size $ unwrap index) <>
+      "Added " <>
-    " definitions and " <>
+      show (Trie.size $ unwrap index) <>
-    show (List.length $ join $ map snd $ Trie.entriesUnordered (unwrap index)) <>
+      " definitions and " <>
-    " type definitions"
+      show (List.length $ join $ map snd $ Trie.entriesUnordered (unwrap index)) <>
-  where ignore _ _ _ = unit
+      " type definitions to the search index."
+
+  where ignore _ _ _ _ = unit
 
 -- | Exit early if something is missing.
-checkDirectories :: Aff Unit
+checkDirectories :: Config -> Aff Unit
-checkDirectories = do
+checkDirectories cfg = do
-  for_ config.requiredDirectories \dir -> do
+
+  let dirs = [ cfg.generatedDocs
+             , cfg.generatedDocs <> "/html"
+             ]
+
+  for_ dirs \dir -> do
     whenM (not <$> directoryExists dir) $
-      liftEffect $ logAndExit "Generate the documentation first!"
+      liftEffect do
+        logAndExit "Build the documentation first!"
 
--- | Read and decode all `docs.json` files in the `outputDir`.
+-- | Read and decode given `docs.json` files.
-collectDocsJsons :: String -> Aff (Array DocsJson)
+decodeDocsJsons
-collectDocsJsons outputDir = do
+  :: forall rest
-  paths <- readdir outputDir
+  .  { docsFiles :: Array String | rest }
+  -> Aff (Array DocsJson)
+decodeDocsJsons cfg = do
 
-  Array.catMaybes <$> for paths \moduleName -> do
+  paths <- Array.concat <$> for cfg.docsFiles \str -> do
-    let jsonFile = "output/" <> moduleName <> "/docs.json"
+    liftEffect $ glob str
+
+  when (Array.null paths) do
+    liftEffect do
+      logAndExit $
+        "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
+
     if doesExist then do
 
       contents <- readTextFile UTF8 jsonFile
@@ -92,20 +120,27 @@ collectDocsJsons outputDir = do
       case eiResult of
         Left error -> do
           liftEffect $ log $
-            "\"docs.json\" decoding failed failed for module " <> moduleName <> ": " <> show error
+            "\"docs.json\" decoding failed failed for " <> jsonFile <> ": " <> show error
           pure Nothing
         Right result -> pure result
 
     else do
       liftEffect $ do
         log $
-          "Couldn't find docs.json for " <> moduleName
+          "File does not exist: " <> jsonFile
       pure Nothing
 
-writeTypeIndex :: TypeIndex -> Aff Unit
+  when (Array.null docsJsons) do
-writeTypeIndex typeIndex =
+    liftEffect $ logAndExit $
+      "Couldn't decode any of the files matched by the following globs: " <> showGlobs cfg.docsFiles
+
+  pure docsJsons
+
+-- | Write type index parts to files.
+writeTypeIndex :: Config -> TypeIndex -> Aff Unit
+writeTypeIndex { generatedDocs } typeIndex =
   for_ entries \(Tuple typeShape results) -> do
-    writeTextFile UTF8 ("generated-docs/index/types/" <> typeShape <> ".js")
+    writeTextFile UTF8 (generatedDocs <> "/index/types/" <> typeShape <> ".js")
       (mkHeader typeShape <> stringify (encodeJson results))
   where
     mkHeader typeShape =
@@ -119,11 +154,7 @@ getIndex :: Declarations -> Map Int (Array (Tuple String (Array SearchResult)))
 getIndex (Declarations trie) =
   Array.foldr insert mempty parts
     where
-      prefixes :: Array (List Char)
+      insert part = Map.insertWith append (getPartId part.prefix) part.results
-      prefixes =
-        Set.toUnfoldable $
-        List.foldr (\entry -> Set.insert (List.take 2 $ fst entry)) mempty $
-        Trie.entriesUnordered trie
 
       parts
         :: Array { prefix :: List Char
@@ -131,24 +162,35 @@ getIndex (Declarations trie) =
                  }
       parts = prefixes <#> \prefix ->
         let results =
-              Array.fromFoldable $
+              Array.fromFoldable $ toTuple <$>
-              Trie.query prefix trie <#>
+              if List.length prefix == 2 then
-              \(Tuple path value) ->
+                 Trie.query prefix trie
-              Tuple (path >#> String.singleton) (Array.fromFoldable value)
+              else
+                -- Entries with path lengths > 1 have been added already.
+                List.filter (\(Tuple path value) -> List.length path == 1) (
+                  Trie.query prefix trie
+                )
         in
          { prefix, results }
 
-      insert part = Map.insertWith append (getPartId part.prefix) part.results
+      toTuple (Tuple path value) =
+        Tuple (path >#> String.singleton) (Array.fromFoldable value)
 
-writeIndex :: Declarations -> Aff Unit
+      prefixes :: Array (List Char)
-writeIndex = getIndex >>> \resultsMap -> do
+      prefixes =
+        Set.toUnfoldable $
+        List.foldr (\path -> Set.insert (List.take 2 path)) mempty $
+        fst <$> Trie.entriesUnordered trie
+
+writeIndex :: Config -> Declarations -> Aff Unit
+writeIndex { generatedDocs } = getIndex >>> \resultsMap -> do
   for_ (Map.toUnfoldableUnordered resultsMap :: Array _)
     \(Tuple indexPartId results) -> do
       let header =
             "// This file was generated by purescript-docs-search.\n" <>
             "window.DocsSearchIndex[\"" <> show indexPartId <> "\"] = "
 
-      writeTextFile UTF8 (config.mkIndexPartPath indexPartId) $
+      writeTextFile UTF8 (generatedDocs <> config.mkIndexPartPath indexPartId) $
         header <> stringify (encodeJson results)
 
 patchHTML :: String -> Tuple Boolean String
@@ -166,9 +208,9 @@ patchHTML html =
      then Tuple true $ String.replace pattern (Replacement patch) html
      else Tuple false html
 
-patchDocs :: Aff Unit
+patchDocs :: Config -> Aff Unit
-patchDocs = do
+patchDocs cfg = do
-  let dirname = "generated-docs/"
+  let dirname = cfg.generatedDocs
 
   files <- readdir (dirname <> "html")
 
@@ -182,14 +224,13 @@ patchDocs = do
           writeTextFile UTF8 path patchedContents
         _ -> pure unit
 
-createDirectories :: Aff Unit
+createDirectories :: Config -> Aff Unit
-createDirectories = do
+createDirectories { generatedDocs } = do
-  let generatedDocsDir = "generated-docs/"
+  let indexDir         = generatedDocs <> "/index"
-      indexDir         = "generated-docs/index"
+      declIndexDir     = generatedDocs <> "/index/declarations"
-      declIndexDir     = "generated-docs/index/declarations"
+      typeIndexDir     = generatedDocs <> "/index/types"
-      typeIndexDir     = "generated-docs/index/types"
 
-  whenM (not <$> directoryExists generatedDocsDir) $ liftEffect do
+  whenM (not <$> directoryExists generatedDocs) $ liftEffect do
     logAndExit "Generate the documentation first!"
 
   whenM (not <$> directoryExists indexDir) do
@@ -201,6 +242,20 @@ createDirectories = do
   whenM (not <$> directoryExists typeIndexDir) do
     mkdir typeIndexDir
 
+-- | 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
+  appDir <- liftEffect getDirname
+  let appFile = appDir <> "/docs-search-app.js"
+  whenM (not <$> fileExists appFile) do
+    liftEffect do
+      logAndExit $
+        "Client-side app was not found at " <> appFile <> ".\n" <>
+        "Check your installation."
+  buffer <- readFile appFile
+  writeFile (generatedDocs <> "/docs-search-app.js") buffer
+
 directoryExists :: String -> Aff Boolean
 directoryExists path = do
   doesExist <- exists path
@@ -216,6 +271,12 @@ fileExists path = do
     true -> isFile <$> stat path
 
 logAndExit :: forall a. String -> Effect a
-logAndExit err = do
+logAndExit message = do
-  log err
+  log message
   Process.exit 1
+
+showGlobs :: Array String -> String
+showGlobs = Array.intercalate ", "
+
+-- | Get __dirname.
+foreign import getDirname :: Effect String

src/Docs/Search/Interactive.js

@@ -0,0 +1,5 @@
+/* global exports */
+
+exports.consoleClear = function () {
+  console.clear();
+};

src/Docs/Search/Interactive.purs

@@ -0,0 +1,258 @@
+module Docs.Search.Interactive where
+
+import Prelude
+
+import Docs.Search.Declarations (Declarations, mkDeclarations)
+import Docs.Search.DocsJson (DataDeclType(..))
+import Docs.Search.Engine (isValuableTypeQuery)
+import Docs.Search.Engine as SearchEngine
+import Docs.Search.IndexBuilder as IndexBuilder
+import Docs.Search.SearchResult (ResultInfo(..), SearchResult(..))
+import Docs.Search.Terminal (bold, cyan, green, yellow)
+import Docs.Search.TypeDecoder (Constraint, FunDeps, Kind, QualifiedName, Type, TypeArgument)
+import Docs.Search.TypeIndex (mkTypeIndex)
+import Docs.Search.TypePrinter (keyword, showConstraint, showFunDeps, showKind, showType, showTypeArgument, space, syntax)
+import Docs.Search.TypeQuery (parseTypeQuery)
+
+import Data.Array as Array
+import Data.Either (hush)
+import Data.List as List
+import Data.Map as Map
+import Data.Maybe (Maybe(..), fromMaybe)
+import Data.Newtype (unwrap, wrap)
+import Data.Search.Trie as Trie
+import Data.String (length) as String
+import Data.String.CodeUnits (fromCharArray, toCharArray) as String
+import Data.String.Common (split, toLower, trim) as String
+import Data.Tuple (snd, fst)
+import Effect (Effect)
+import Effect.Aff (launchAff_)
+import Effect.Class (liftEffect)
+import Effect.Console (log)
+import Node.ReadLine (createConsoleInterface, question)
+
+type Config = { docsFiles :: Array String }
+
+run :: Config -> Effect Unit
+run cfg = launchAff_ $ do
+
+  liftEffect do
+    log "Loading search index..."
+
+  docsJsons <- IndexBuilder.decodeDocsJsons cfg
+
+  let index = mkDeclarations docsJsons
+      typeIndex = Array.concat $ Array.fromFoldable (
+        Map.values (unwrap (mkTypeIndex index)) <#> fromMaybe []
+      ) :: Array SearchResult
+
+  liftEffect do
+    log $
+      "Loaded " <>
+      show (Trie.size $ unwrap index) <>
+      " definitions and " <>
+      show (List.length $ join $ map snd $ Trie.entriesUnordered (unwrap index)) <>
+      " type definitions"
+
+  liftEffect do
+    let
+      call handler interface = do
+        question "> " (handler interface) interface
+
+      inputHandler interface input = do
+        let results =
+              case hush (parseTypeQuery input) >>= isValuableTypeQuery of
+                Nothing ->
+                  Array.fromFoldable $
+                  List.concat $
+                  Trie.queryValues (List.fromFoldable $
+                                    String.toCharArray $
+                                    String.toLower $
+                                    input) (unwrap index)
+
+                Just typeQuery ->
+                  Array.take 100 $
+                  SearchEngine.sortByDistance typeQuery typeIndex
+
+        let total = Array.length results
+
+        consoleClear
+
+        if total > 0 then do
+          log $
+            Array.intercalate "\n\n\n" $
+            showResult <$> Array.reverse results
+        else do
+          log $
+            "Your search for " <> bold input <> " did not yield any results."
+        call inputHandler interface
+
+    interface <- do
+      interface <- createConsoleInterface (mkCompleter index)
+      pure interface
+
+    call inputHandler interface
+
+mkCompleter
+  :: Declarations
+  -> String
+  -> Effect { completions :: Array String
+            , matched :: String }
+mkCompleter index input = do
+  let path = List.fromFoldable $ String.toCharArray input
+  let paths =
+        Array.fromFoldable $
+        (String.fromCharArray <<< Array.fromFoldable) <$>
+        (fst <$> Trie.query path (unwrap index))
+
+  pure { completions: paths
+       , matched: input }
+
+showResult :: SearchResult -> String
+showResult result@(SearchResult { name, comments, moduleName, packageName, info }) =
+  showSignature result <> "\n" <>
+
+  (fromMaybe "\n" $
+   comments <#> \comment ->
+   "\n" <> leftShift 3 (String.trim comment) <> "\n\n") <>
+
+  bold (cyan (rightPad 40 packageName)) <> space <> bold (green moduleName)
+
+showSignature :: SearchResult -> String
+showSignature result@(SearchResult { name, info }) =
+  case info of
+    ValueResult { type: ty } ->
+      yellow name <> syntax " :: " <> showType ty
+
+    TypeClassResult info' ->
+      showTypeClassSignature info' (unwrap result)
+
+    TypeClassMemberResult info' ->
+      showTypeClassMemberSignature info' (unwrap result)
+
+    DataResult info' ->
+      showDataSignature info' (unwrap result)
+
+    TypeSynonymResult info' ->
+      showTypeSynonymSignature info' (unwrap result)
+
+    ExternDataResult info' ->
+      showExternDataSignature info' (unwrap result)
+
+    ValueAliasResult ->
+      yellow ("(" <> name <> ")")
+
+    _ -> yellow name
+
+showTypeClassSignature
+  :: forall rest
+  .  { fundeps :: FunDeps
+     , arguments :: Array TypeArgument
+     , superclasses :: Array Constraint
+     }
+  -> { name :: String, moduleName :: String | rest }
+  -> String
+showTypeClassSignature { fundeps, arguments, superclasses } { name, moduleName } =
+
+  keyword "class" <>
+  ( if Array.null superclasses
+    then
+      ""
+    else
+      syntax " (" <> (
+        Array.intercalate (syntax ", " ) (
+          superclasses <#> showConstraint
+        )
+      ) <>
+      syntax ")" <>
+      space <>
+      syntax "<="
+  ) <>
+  space <>
+  yellow name <>
+  space <> (
+    Array.intercalate space $
+      arguments <#> showTypeArgument
+  ) <> (
+    showFunDeps fundeps
+  )
+
+showTypeClassMemberSignature
+  :: forall rest
+  .  { type :: Type
+     , typeClass :: QualifiedName
+     , typeClassArguments :: Array String
+     }
+  -> { name :: String | rest }
+  -> String
+showTypeClassMemberSignature { type: ty, typeClass, typeClassArguments } result =
+  yellow result.name <>
+  syntax " :: " <>
+  showType ty
+
+showDataSignature
+  :: forall rest
+  .  { typeArguments :: Array TypeArgument
+     , dataDeclType :: DataDeclType }
+  -> { name :: String | rest }
+  -> String
+showDataSignature { typeArguments, dataDeclType } { name } =
+  ( keyword
+    case dataDeclType of
+      NewtypeDataDecl -> "newtype"
+      DataDataDecl    -> "data"
+  ) <>
+  space <>
+  yellow name <>
+  space <> (
+    Array.intercalate space $
+      typeArguments <#> showTypeArgument
+  )
+
+showTypeSynonymSignature
+  :: forall rest
+  .  { type :: Type
+     , arguments :: Array TypeArgument
+     }
+  -> { name :: String | rest }
+  -> String
+showTypeSynonymSignature { type: ty, arguments } { name } =
+  keyword "type" <>
+  space <>
+  yellow name <>
+  space <> (
+    Array.intercalate space $
+      arguments <#> showTypeArgument
+  ) <>
+  space <>
+  syntax "=" <>
+  space <>
+  showType ty
+
+showExternDataSignature
+  :: forall rest
+  .  { kind :: Kind }
+  -> { name :: String | rest }
+  -> String
+showExternDataSignature { kind } { name } =
+  keyword "foreign data" <>
+  space <>
+  yellow name <>
+  space <>
+  syntax " :: " <>
+  showKind kind
+
+leftShift :: Int -> String -> String
+leftShift shift str =
+  Array.intercalate "\n" $
+  leftPad shift <$>
+  String.trim <$>
+  String.split (wrap "\n") str
+
+leftPad :: Int -> String -> String
+leftPad w str = Array.fold (Array.replicate w " ") <> str
+
+rightPad :: Int -> String -> String
+rightPad w str = str <> Array.fold (Array.replicate (w - String.length str) " ")
+
+foreign import consoleClear :: Effect Unit

src/Docs/Search/Main.purs

@@ -0,0 +1,103 @@
+module Docs.Search.Main where
+
+import Prelude
+
+import Docs.Search.IndexBuilder as IndexBuilder
+import Docs.Search.Interactive as Interactive
+
+import Data.Generic.Rep (class Generic)
+import Data.Generic.Rep.Show (genericShow)
+import Data.List as List
+import Data.List.NonEmpty as NonEmpty
+import Data.Maybe (Maybe, fromMaybe, optional)
+import Data.Unfoldable (class Unfoldable)
+import Effect (Effect)
+import Options.Applicative (Parser, command, execParser, fullDesc, helper, info, long, metavar, progDesc, strOption, subparser, value, (<**>))
+import Options.Applicative as CA
+
+main :: Effect Unit
+main = do
+
+  args <- getArgs
+  let defaultCommands = Search { docsFiles: defaultDocsFiles }
+
+  case fromMaybe defaultCommands args of
+    BuildIndex cfg -> IndexBuilder.run cfg
+    Search cfg -> Interactive.run cfg
+
+getArgs :: Effect (Maybe Commands)
+getArgs = execParser opts
+  where
+    opts =
+      info (commands <**> helper)
+      ( fullDesc
+     <> progDesc "Search frontend for the documentation generated by the PureScript compiler."
+      )
+
+data Commands
+  = BuildIndex { docsFiles :: Array String
+               , generatedDocs :: String
+               }
+  | Search { docsFiles :: Array String }
+
+derive instance genericCommands :: Generic Commands _
+
+instance showCommands :: Show Commands where
+  show = genericShow
+
+commands :: Parser (Maybe Commands)
+commands = optional $ subparser
+  ( command "build-index"
+    ( info buildIndex
+      ( progDesc "Build the index used to search for definitions and patch the generated docs so that they include a search field."
+      )
+    )
+ <> command "search"
+    ( info startInteractive
+      ( progDesc "Run the search engine."
+      )
+    )
+  )
+
+buildIndex :: Parser Commands
+buildIndex = ado
+
+  docsFiles <- fromMaybe defaultDocsFiles <$>
+   optional (
+     some ( strOption
+            ( long "docs-files"
+              <> metavar "GLOB"
+            )
+     )
+   )
+
+  generatedDocs <- strOption
+    ( long "generated-docs"
+   <> metavar "DIR"
+   <> value "./generated-docs/"
+    )
+
+  in BuildIndex { docsFiles, generatedDocs }
+
+startInteractive :: Parser Commands
+startInteractive = ado
+
+  docsFiles <- fromMaybe defaultDocsFiles <$>
+   optional (
+     some ( strOption
+            ( long "docs-files"
+           <> metavar "GLOB"
+            )
+     )
+   )
+
+  in Search { docsFiles }
+
+defaultDocsFiles :: Array String
+defaultDocsFiles = [ "output/**/docs.json" ]
+
+many :: forall a f. Unfoldable f => Parser a -> Parser (f a)
+many x = CA.many x <#> List.toUnfoldable
+
+some :: forall a f. Unfoldable f => Parser a -> Parser (f a)
+some x = CA.some x <#> NonEmpty.toUnfoldable

src/Docs/Search/Terminal.purs

@@ -0,0 +1,23 @@
+module Docs.Search.Terminal where
+
+import Prelude
+
+bold :: String -> String
+bold str =
+  "\x1b[1m" <> str <> "\x1b[0m"
+
+yellow :: String -> String
+yellow str =
+  "\x1b[33m" <> str <> "\x1b[0m"
+
+grey :: String -> String
+grey str =
+  "\x1b[37m" <> str <> "\x1b[0m"
+
+cyan :: String -> String
+cyan str =
+  "\x1b[36m" <> str <> "\x1b[0m"
+
+green :: String -> String
+green str =
+  "\x1b[32m" <> str <> "\x1b[0m"

src/Docs/Search/TypeIndex.purs

@@ -69,23 +69,23 @@ mkTypeIndex (Declarations trie) = TypeIndex $ map (Array.fromFoldable >>> Just)
 lookup
   :: String
   -> TypeIndex
-  -> Aff { index :: TypeIndex, results :: Array SearchResult }
+  -> Aff { typeIndex :: TypeIndex, results :: Array SearchResult }
-lookup key index@(TypeIndex map) =
+lookup key typeIndex@(TypeIndex map) =
   case Map.lookup key map of
-    Just results -> pure { index, results: Array.fold results }
+    Just results -> pure { typeIndex, results: Array.fold results }
     Nothing -> do
       eiJson <- try (toAffE (lookup_ key $ config.mkShapeScriptPath key))
       pure $ fromMaybe'
-        (\_ ->  { index: insert key Nothing index, results: [] })
+        (\_ ->  { typeIndex: insert key Nothing typeIndex, results: [] })
         do
           json <- hush eiJson
           results <- hush (decodeJson json)
-          pure { index: insert key (Just results) index, results }
+          pure { typeIndex: insert key (Just results) typeIndex, results }
 
 query
   :: TypeIndex
   -> TypeQuery
-  -> Aff { index :: TypeIndex, results :: Array SearchResult }
+  -> Aff { typeIndex :: TypeIndex, results :: Array SearchResult }
 query typeIndex typeQuery = do
   res <- lookup (stringifyShape $ shapeOfTypeQuery typeQuery) typeIndex
   pure $ res { results = sortByRelevance typeQuery res.results }

src/Docs/Search/TypePrinter.purs

@@ -0,0 +1,156 @@
+module Docs.Search.TypePrinter where
+
+import Prelude
+
+import Docs.Search.Terminal (cyan)
+import Docs.Search.TypeDecoder (Constraint(..), FunDep(..), FunDeps(..), Kind(..), QualifiedName(..), Type(..), TypeArgument(..), joinForAlls, joinRows)
+
+import Data.Maybe (Maybe(..))
+import Data.Array as Array
+import Data.List as List
+
+showType :: Type -> String
+showType = case _ of
+  TypeVar str -> str
+  TypeLevelString str -> "\"" <> str <> "\"" -- TODO: add escaping
+  TypeWildcard -> "_"
+  TypeConstructor qname -> showQualifiedName qname
+  TypeOp qname -> showQualifiedName qname
+
+  TypeApp (TypeApp (TypeConstructor
+                    (QualifiedName { moduleName: [ "Prim" ]
+                                   , name: "Function" })) t1) t2 ->
+    showType t1 <> syntax " -> " <> showType t2
+
+  TypeApp (TypeConstructor (QualifiedName { moduleName: [ "Prim" ]
+                                          , name: "Record" }))
+          row ->
+    showRow false row
+
+  TypeApp t1 t2 ->
+    showType t1 <> " " <> showType t2
+
+  ty@(ForAll _ _ _) ->
+    showForAll ty
+
+  ConstrainedType cnstr ty ->
+    showConstraint cnstr <>
+    syntax " => " <>
+    showType ty
+
+  ty@REmpty -> showRow true ty
+  ty@(RCons _ _ _) -> showRow true ty
+
+  BinaryNoParensType op t1 t2 ->
+    showType t1 <>
+    space <>
+    showType op <>
+    space <>
+    showType t2
+
+  ParensInType ty ->
+    "(" <>
+    showType ty <>
+    ")"
+
+showTypeArgument :: TypeArgument -> String
+showTypeArgument (TypeArgument { name, mbKind }) =
+  case mbKind of
+    Nothing ->
+      name
+    Just kind ->
+      "(" <>
+      name <>
+      " :: " <>
+      showKind kind <>
+      ")"
+
+showFunDeps :: FunDeps -> String
+showFunDeps (FunDeps []) = ""
+showFunDeps (FunDeps deps) =
+  append (syntax " | ") $
+  Array.intercalate (syntax ", ") $
+  deps <#> renderFunDep
+  where
+    renderFunDep (FunDep { lhs, rhs }) =
+      Array.intercalate space lhs <>
+      syntax " -> " <>
+      Array.intercalate space rhs
+
+showQualifiedName
+  :: QualifiedName
+  -> String
+showQualifiedName (QualifiedName { name })
+  = name
+
+showRow
+  :: Boolean
+  -> Type
+  -> String
+showRow asRow =
+  joinRows >>> \ { rows, ty } ->
+  if List.null rows
+  then
+    if asRow then "()" else "{}"
+  else
+    opening <>
+    ( Array.intercalate ", " $ Array.fromFoldable $ rows <#>
+      \entry ->
+      entry.row <> syntax " :: " <> showType entry.ty
+    ) <>
+
+    case ty of
+      Just ty' -> " | " <> showType ty' <> closing
+      Nothing  -> closing
+
+    where
+      opening = if asRow then "(" else "{ "
+      closing = if asRow then ")" else " }"
+
+showForAll
+  :: Type
+  -> String
+showForAll ty =
+  keyword "forall" <>
+
+  ( Array.fold $ foralls.binders <#>
+    \ { var, mbKind } ->
+    case mbKind of
+      Nothing -> " " <> var
+      Just kind ->
+        " (" <> var <> " "
+        <> syntax "::"
+        <> space
+        <> showKind kind
+        <> ")"
+  ) <>
+
+  syntax ". " <>
+  showType foralls.ty
+
+  where
+    foralls = joinForAlls ty
+
+showKind
+  :: Kind
+  -> String
+showKind = case _ of
+  Row k1          -> "# " <> showKind k1
+  FunKind k1 k2   -> showKind k1 <> syntax " -> " <> showKind k2
+  NamedKind qname -> showQualifiedName qname
+
+showConstraint
+  :: Constraint
+  -> String
+showConstraint (Constraint { constraintClass, constraintArgs }) =
+  showQualifiedName constraintClass <> space <>
+  Array.intercalate space (constraintArgs <#> showType)
+
+syntax :: String -> String
+syntax = cyan
+
+space :: String
+space = " "
+
+keyword :: String -> String
+keyword = cyan

src/Docs/Search/TypeQuery.purs

@@ -1,3 +1,4 @@
+-- | `TypeQuery` is a representation of a user-provided type.
 module Docs.Search.TypeQuery
        ( TypeQuery(..)
        , Substitution(..)
@@ -11,24 +12,21 @@ where
 
 import Prelude
 
-import Docs.Search.Config
+import Docs.Search.Config (config)
-import Docs.Search.DocsJson
+import Docs.Search.Extra (foldl1, foldr1)
-import Docs.Search.TypeDecoder
+import Docs.Search.TypeDecoder (QualifiedName(..), Type(..), joinConstraints, joinRows)
 
 import Control.Alt ((<|>))
 import Data.Array as Array
 import Data.Either (Either)
-import Data.Foldable (foldl)
 import Data.Generic.Rep (class Generic)
 import Data.Generic.Rep.Show (genericShow)
 import Data.List (List(..), many, some, (:))
 import Data.List as List
-import Data.List.NonEmpty (NonEmptyList, cons', uncons)
+import Data.List.NonEmpty (NonEmptyList)
 import Data.List.NonEmpty as NonEmptyList
 import Data.Map (Map)
 import Data.Map as Map
-import Data.Maybe (Maybe(..))
-import Data.Newtype (unwrap)
 import Data.Ord (abs)
 import Data.Set (Set)
 import Data.Set as Set
@@ -93,25 +91,12 @@ typeQueryParser = fix \typeQuery ->
 
       constrained =
         QConstraint <$> (upperCaseIdent <* skipSpaces) <*>
-                        (sepEndBy ((QVar <$> ident) <|> parens) (many space) <* string "=>" <* skipSpaces) <*>
+                        (sepEndBy ((QVar <$> ident) <|> parens)
+                                  (many space) <* string "=>" <* skipSpaces) <*>
                         typeQuery
   in
     try constrained <|> funs
 
-foldl1 :: forall a. (a -> a -> a) -> NonEmptyList a -> a
-foldl1 f as =
-  case uncons as of
-    { head, tail } -> foldl f head tail
-
-foldr1 :: forall a. (a -> a -> a) -> NonEmptyList a -> a
-foldr1 f = go List.Nil
-  where
-    go acc x = case uncons x of
-      { head, tail } -> case List.uncons tail of
-        Nothing -> List.foldl (flip f) head acc
-        Just { head: head1, tail: tail1 } ->
-          go (head : acc) (cons' head1 tail1)
-
 any :: Parser TypeQuery
 any = do
   QVar <$> lowerCaseIdent
@@ -188,7 +173,12 @@ data Substitution
   | MissingConstraint
   | ExcessiveConstraint
   | RowsMismatch Int Int
-  | Mismatch
+  | Mismatch TypeQuery Type
+  -- ^ Type and type query significantly differ.
+  | TypeMismatch Type
+  -- ^ A query of size 1 corresponds to some type.
+  | QueryMismatch TypeQuery
+  -- ^ A type of size 1 corresponds to some query.
 
 derive instance genericSubstitution :: Generic Substitution _
 
@@ -204,45 +194,11 @@ unify query type_ = go Nil (List.singleton { q: query, t: type_ })
         go acc ({ q, t } : rest)
 
     -- * ForAll
-    go acc ({ q: (QForAll queryBinders q), t:type_1@(ForAll _ _ _) } : rest) =
-      let { binders, ty } = joinForAlls type_1 in
-        go acc ({ q, t: ty } : rest)
     go acc ({ q, t: ForAll _ t _ } : rest) =
         go acc ({ q, t } : rest)
-    go acc ({ q: (QForAll queryBinders q), t } : rest) =
+    go acc ({ q: (QForAll _ q), t } : rest) =
         go acc ({ q, t } : rest)
 
-    -- * Type variables
-    go acc ({ q: QVar q, t: TypeVar v } : rest) =
-      go (Substitute q v : acc) rest
-    go acc ({ q, t: TypeVar v } : rest ) =
-      go (Generalize q v : acc) rest
-    go acc ({ q: QVar v, t } : rest) =
-      go (Instantiate v t : acc) rest
-
-    -- * Names
-    go acc ({ q: QConst qname, t: TypeConstructor (QualifiedName { name }) } : rest) =
-      go (Match qname name : acc) rest
-    go acc ({ q: QConst qname, t } : rest) =
-      go (Mismatch : acc) rest
-    go acc ({ q, t: TypeConstructor (QualifiedName { name }) } : rest) =
-      go (Mismatch : acc) rest
-
-    -- type operators can't appear in type queries: this is always a mismatch
-    go acc ({ q, t: TypeOp (QualifiedName { name }) } : rest) =
-      go (Mismatch : acc) rest
-    go acc ({ q, t: BinaryNoParensType _ _ _ } : rest) =
-      go (Mismatch : acc) rest
-
-    -- * Functions
-    go acc ({ q: QFun q1 q2
-            , t: TypeApp (TypeApp (TypeConstructor
-                                    (QualifiedName { moduleName: [ "Prim" ]
-                                                   , name: "Function" })) t1) t2 } : rest) =
-      go acc ({ q: q1, t: t1 } : { q: q2, t: t2 } : rest)
-    go acc ({ q: QFun q1 q2, t } : rest) =
-      go (Mismatch : acc) rest
-
     -- * Constraints
     go acc ({ q: q@(QConstraint _ _ _)
             , t: t@(ConstrainedType _ _) } : rest) =
@@ -256,6 +212,37 @@ unify query type_ = go Nil (List.singleton { q: query, t: type_ })
     go acc ({ q, t: ConstrainedType _ t } : rest) =
       go (MissingConstraint : acc) ({ q, t } : rest)
 
+    -- * Type variables
+    go acc ({ q: QVar q, t: TypeVar v } : rest) =
+      go (Substitute q v : acc) rest
+    go acc ({ q, t: TypeVar v } : rest ) =
+      go (Generalize q v : acc) rest
+    go acc ({ q: QVar v, t } : rest) =
+      go (Instantiate v t : acc) rest
+
+    -- * Names
+    go acc ({ q: QConst qname, t: TypeConstructor (QualifiedName { name }) } : rest) =
+      go (Match qname name : acc) rest
+    go acc ({ q: QConst qname, t } : rest) =
+      go (TypeMismatch t : acc) rest
+    go acc ({ q, t: TypeConstructor (QualifiedName { name }) } : rest) =
+      go (QueryMismatch q : acc) rest
+
+    -- type operators can't appear in type queries: this is always a mismatch
+    go acc ({ q, t: TypeOp (QualifiedName { name }) } : rest) =
+      go (QueryMismatch q : acc) rest
+    go acc ({ q, t: t@(BinaryNoParensType _ _ _) } : rest) =
+      go (Mismatch q t : acc) rest
+
+    -- * Functions
+    go acc ({ q: QFun q1 q2
+            , t: TypeApp (TypeApp (TypeConstructor
+                                    (QualifiedName { moduleName: [ "Prim" ]
+                                                   , name: "Function" })) t1) t2 } : rest) =
+      go acc ({ q: q1, t: t1 } : { q: q2, t: t2 } : rest)
+    go acc ({ q: q@(QFun q1 q2), t } : rest) =
+      go (Mismatch q t : acc) rest
+
     -- * Rows
     go acc ({ q: QApp (QConst "Record") (QRow qRows)
             , t: TypeApp (TypeConstructor
@@ -278,24 +265,24 @@ unify query type_ = go Nil (List.singleton { q: query, t: type_ })
         else
           go (RowsMismatch qRowsLength rowsLength : acc) rest
 
-    go acc ({ q: QRow _ } : rest) =
+    go acc ({ q: q@(QRow _), t } : rest) =
-      go (Mismatch : acc) rest
+      go (Mismatch q t : acc) rest
 
     -- * Type application
     go acc ({ q: QApp q1 q2, t: TypeApp t1 t2 } : rest) =
       go acc ({ q: q1, t: t1 } : { q: q2, t: t2 } : rest)
 
     go acc ({ q, t: TypeLevelString _ } : rest) =
-      go (Mismatch : acc) rest
+      go (QueryMismatch q : acc) rest
 
     go acc ({ q, t: TypeWildcard } : rest) =
-      go (Mismatch : acc) rest
+      go (QueryMismatch q : acc) rest
 
-    go acc ({ q, t: RCons _ _ _ } : rest) =
+    go acc ({ q, t: t@(RCons _ _ _) } : rest) =
-      go (Mismatch : acc) rest
+      go (Mismatch q t : acc) rest
 
     go acc ({ q, t: REmpty } : rest) =
-      go (Mismatch : acc) rest
+      go (QueryMismatch q : acc) rest
 
 penalty :: TypeQuery -> Type -> Int
 penalty typeQuery ty =
@@ -332,7 +319,6 @@ namesPenalty :: List Substitution -> Int
 namesPenalty = go 0
   where
     go p Nil = p
-    go p (Mismatch : rest) = go (p + config.penalties.mismatch) rest
     go p (Match a b : rest)
       | a == b = go p rest
       | otherwise = go (p + config.penalties.match) rest
@@ -348,10 +334,15 @@ mismatchPenalty :: List Substitution -> Int
 mismatchPenalty = go 0
   where
     go n Nil = n
-    go n (Instantiate _ _     : rest) = go (n + config.penalties.instantiate)         rest
+    go n (Instantiate q t     : rest) = go (n + typeSize t *
-    go n (Generalize _ _      : rest) = go (n + config.penalties.generalize)          rest
+                                            config.penalties.instantiate)             rest
+    go n (Generalize q t      : rest) = go (n + typeQuerySize q *
+                                            config.penalties.generalize)              rest
     go n (ExcessiveConstraint : rest) = go (n + config.penalties.excessiveConstraint) rest
     go n (MissingConstraint   : rest) = go (n + config.penalties.missingConstraint)   rest
+    go n (Mismatch q t        : rest) = go (n + typeQuerySize q + typeSize t)         rest
+    go n (TypeMismatch t      : rest) = go (n + typeSize t)                           rest
+    go n (QueryMismatch q     : rest) = go (n + typeQuerySize q)                      rest
     go n (_ : rest) = go n rest
 
 -- | Only returns a list of type class names (lists of arguments are omitted).
@@ -362,3 +353,55 @@ joinQueryConstraints = go Nil
     go acc (QConstraint name _ query) =
       go (name : acc) query
     go acc ty = { constraints: List.sort acc, ty }
+
+typeQuerySize :: TypeQuery -> Int
+typeQuerySize = go 0 <<< List.singleton
+  where
+    go n Nil = n
+    go n (QVar _ : rest) =
+      go (n + 1) rest
+    go n (QConst _ : rest) =
+      go (n + 1) rest
+    go n (QFun q1 q2 : rest) =
+      go (n + 1) (q1 : q2 : rest)
+    go n (QApp q1 q2 : rest) =
+      go (n + 1) (q1 : q2 : rest)
+    go n (QForAll _ q : rest) =
+      go (n + 1) (q : rest)
+    go n (QConstraint _ _ q : rest) =
+      go (n + 1) (q : rest)
+    go n (QRow qs : rest) =
+      go n       ((qs <#> snd) <> rest)
+
+typeSize :: Type -> Int
+typeSize = go 0 <<< List.singleton
+  where
+    go n Nil = n
+    go n (TypeVar _ : rest) =
+      go (n + 1) rest
+    go n (TypeLevelString _ : rest) =
+      go (n + 1) rest
+    go n (TypeWildcard : rest) =
+      go (n + 1) rest
+    go n (TypeConstructor _ : rest) =
+      go (n + 1) rest
+    go n (TypeOp _ : rest) =
+      go (n + 1) rest
+    go n (TypeApp (TypeApp (TypeConstructor
+                    (QualifiedName { moduleName: [ "Prim" ]
+                                   , name: "Function" })) t1) t2 : rest) =
+      go (n + 1) (t1 : t2 : rest)
+    go n (TypeApp q1 q2 : rest) =
+      go (n + 1) (q1 : q2 : rest)
+    go n (ForAll _ t _ : rest) =
+      go (n + 1) (t : rest)
+    go n (ConstrainedType _ t : rest) =
+      go (n + 1) (t : rest)
+    go n (RCons _ t1 t2 : rest) =
+      go (n + 1) (t1 : t2 : rest)
+    go n (REmpty : rest) =
+      go (n + 1) rest
+    go n (BinaryNoParensType op t1 t2 : rest) =
+      go (n + 1) (t1 : t2 : rest)
+    go n (ParensInType t : rest) =
+      go n (t : rest)

test/Test/IndexBuilder.purs

@@ -2,19 +2,9 @@ module Test.IndexBuilder where
 
 import Prelude
 
-import Test.Extra
+import Docs.Search.IndexBuilder (patchHTML)
 
-import Docs.Search.IndexBuilder
+import Data.Tuple (snd)
-
-import Data.Either (Either(..))
-import Data.Foldable (class Foldable)
-import Data.List (List(..), (:))
-import Data.List as List
-import Data.List.NonEmpty (NonEmptyList)
-import Data.List.NonEmpty as NonEmptyList
-import Data.Set as Set
-import Data.Tuple (Tuple(..), snd)
-import Effect.Aff (Aff)
 import Test.Unit (TestSuite, suite, test)
 import Test.Unit.Assert as Assert