Group modules by package in the sidebar

spago.dhall

@@ -29,12 +29,14 @@
     , "node-readline"
     , "optparse"
     , "profunctor"
+    , "profunctor-lenses"
     , "search-trie"
     , "string-parsers"
     , "strings"
     , "test-unit"
     , "web-dom"
     , "web-html"
+    , "web-storage"
     ]
 , packages =
     ./packages.dhall

src/Docs/Search/App.purs

@@ -1,13 +1,14 @@
 -- | This is the main module of the client-side Halogen app.
 module Docs.Search.App where
 
-import Prelude
-
 import Docs.Search.App.SearchField as SearchField
 import Docs.Search.App.SearchResults as SearchResults
+import Docs.Search.App.Sidebar as Sidebar
 import Docs.Search.Extra (whenJust)
+import Docs.Search.ModuleIndex as ModuleIndex
 import Docs.Search.PackageIndex as PackageIndex
 
+import Prelude
 import Control.Coroutine as Coroutine
 import Data.Maybe (Maybe(..))
 import Data.Newtype (wrap)
@@ -17,17 +18,20 @@ import Halogen as H
 import Halogen.Aff as HA
 import Halogen.VDom.Driver (runUI)
 import MarkdownIt as MD
+import Web.DOM.ChildNode as ChildNode
 import Web.DOM.Document as Document
 import Web.DOM.Element as Element
 import Web.DOM.Node as Node
 import Web.DOM.ParentNode as ParentNode
 import Web.DOM.Text as Text
 import Web.Event.EventTarget (addEventListener, eventListener)
 import Web.HTML as HTML
+import Web.HTML.Event.HashChangeEvent.EventTypes (hashchange)
 import Web.HTML.HTMLDocument as HTMLDocument
 import Web.HTML.HTMLElement (fromElement)
 import Web.HTML.Window as Window
-import Web.HTML.Event.HashChangeEvent.EventTypes (hashchange)
+import Web.HTML.Event.EventTypes (focus)
+
 
 main :: Effect Unit
 main = do
@@ -40,11 +44,21 @@ main = do
   -- Initialize a `markdown-it` instance (we need it to render the docs as markdown)
   markdownIt <- MD.newMarkdownIt MD.Default mempty
 
-  whenJust mbContainers \ { searchField, searchResults, pageContents } -> do
+  whenJust mbContainers \ { searchField
+                          , searchResults
+                          , pageContents
+                          , sidebarContainer
+                          , realSidebar } -> do
+
+    -- Hide real sidebar completely - we are going to recreate it as Halogen component.
+    ChildNode.remove $ Element.toChildNode realSidebar
+
     HA.runHalogenAff do
       packageIndex <- PackageIndex.loadPackageIndex
+      moduleIndex <- ModuleIndex.loadModuleIndex
 
       let initialSearchEngineState = { packageIndex: packageIndex
+                                     , moduleIndex: moduleIndex
                                      , index: mempty
                                      , typeIndex: mempty
                                      }
@@ -53,6 +67,9 @@ main = do
             SearchResults.mkComponent initialSearchEngineState pageContents markdownIt
 
       sfio <- runUI SearchField.component unit searchField
+      sbio <- do
+              component <- Sidebar.mkComponent moduleIndex
+              runUI component unit sidebarContainer
       srio <- runUI resultsComponent unit searchResults
 
       sfio.subscribe $
@@ -72,6 +89,16 @@ main = do
 
         addEventListener hashchange listener true (Window.toEventTarget win)
 
+      -- Subscribe to window focus events
+      H.liftEffect do
+
+        listener <-
+          eventListener \event ->
+            launchAff_ do
+              sbio.query $ H.tell Sidebar.UpdateModuleGrouping
+
+        addEventListener focus listener true (Window.toEventTarget win)
+
 
 insertStyle :: Document.Document -> Effect Unit
 insertStyle doc = do
@@ -102,24 +129,49 @@ insertStyle doc = do
     /* Add a margin between badge icons and package/module names. */
     margin-right: 0.25em;
   }
+  .li-package {
+    font-weight: bold;
+    cursor: pointer;
+    color: #c4953a;
+  }
+  /* Make spaces narrower in the sidebar */
+  .li-package > details > ul {
+    margin-top: auto;
+    margin-bottom: auto;
+  }
+  #group-modules__label, #group-modules__input {
+    display: inline-block;
+    vertical-align: middle;
+    color: #666666;
+    font-size: 0.8rem;
+    font-weight: 300;
+    letter-spacing: 1px;
+    margin-bottom: -0.8em;
+  }
+  summary:focus {
+    outline: none;
+  }
   """
 
   mbHead <-
     ParentNode.querySelector (wrap "head") (Document.toParentNode doc)
 
   whenJust mbHead \head -> do
-
     contents <- Document.createTextNode styleContents doc
     style <- Document.createElement "style" doc
     void $ Node.appendChild (Text.toNode contents) (Element.toNode style)
     void $ Node.appendChild (Element.toNode style) (Element.toNode head)
 
+
 -- | Query the DOM for specific elements that should always be present.
 getContainers
   :: Document.Document
   -> Effect (Maybe { searchField :: HTML.HTMLElement
                    , searchResults :: HTML.HTMLElement
-                   , pageContents :: Element.Element })
+                   , pageContents :: Element.Element
+                   , sidebarContainer :: HTML.HTMLElement
+                   , realSidebar :: Element.Element
+                   })
 getContainers doc = do
   let docPN = Document.toParentNode doc
   mbBanner <-
@@ -128,13 +180,21 @@ getContainers doc = do
     ParentNode.querySelector (wrap ".everything-except-footer") docPN
   mbContainer <-
     ParentNode.querySelector (wrap ".everything-except-footer > .container") docPN
+  mbMainContainer <-
+    ParentNode.querySelector (wrap ".everything-except-footer > main") docPN
+  mbRealSidebar <-
+    ParentNode.querySelector (wrap ".col--aside") docPN
   case unit of
-    _ | Just banner       <- mbBanner
-      , Just everything   <- mbEverything
-      , Just pageContents <- mbContainer -> do
+    _ | Just banner        <- mbBanner
+      , Just everything    <- mbEverything
+      , Just pageContents  <- mbContainer
+      , Just mainContainer <- mbMainContainer
+      , Just realSidebar   <- mbRealSidebar -> do
       search <- Document.createElement "div" doc
       void $ Node.appendChild (Element.toNode search) (Element.toNode banner)
-      pure $ fromElement search     >>= \searchField ->
-             fromElement everything >>= \searchResults ->
-             pure { searchField, searchResults, pageContents }
+      pure do
+        searchField <- fromElement search
+        searchResults <- fromElement everything
+        sidebarContainer <- fromElement mainContainer
+        pure { searchField, searchResults, pageContents, realSidebar, sidebarContainer }
       | otherwise -> pure Nothing

src/Docs/Search/App/SearchResults.purs

@@ -168,7 +168,7 @@ hidePageContents
 hidePageContents = do
   state <- H.get
   H.liftEffect do
-    Element.setAttribute "style" "display: none" state.contents
+    Element.setAttribute "style" "display: none;" state.contents
 
 
 render

src/Docs/Search/App/Sidebar.purs

@@ -0,0 +1,157 @@
+module Docs.Search.App.Sidebar where
+
+import Docs.Search.Config (config)
+import Docs.Search.ModuleIndex (ModuleIndex)
+import Docs.Search.Types (ModuleName, PackageName)
+
+import Prelude
+import Data.Array as Array
+import Data.Lens ((.~))
+import Data.Lens.Record (prop)
+import Data.List (foldr)
+import Data.Map (Map)
+import Data.Map as Map
+import Data.Maybe (Maybe(..), isJust)
+import Data.Newtype (wrap)
+import Data.Set (Set)
+import Data.Set as Set
+import Data.Symbol (SProxy(..))
+import Data.Tuple.Nested (type (/\), (/\))
+import Effect (Effect)
+import Effect.Aff (Aff)
+import Halogen as H
+import Halogen.HTML as HH
+import Halogen.HTML.Events as HE
+import Halogen.HTML.Properties as HP
+import Web.HTML as HTML
+import Web.HTML.Window as Window
+import Web.Storage.Storage as Storage
+
+
+data Action = ToggleGrouping GroupingMode
+
+data Query a = UpdateModuleGrouping a
+
+data GroupingMode = GroupByPackage | DontGroup
+
+derive instance groupingModeEq :: Eq GroupingMode
+
+
+type State = { moduleIndex :: Map PackageName (Set ModuleName)
+             , groupingMode :: GroupingMode
+             , moduleNames :: Array ModuleName
+             }
+
+
+mkComponent
+  :: forall i
+  .  ModuleIndex
+  -> Aff (H.Component HH.HTML Query i Action Aff)
+mkComponent moduleIndex = do
+  groupingMode <- H.liftEffect loadGroupingModeFromLocalStorage
+  pure $
+    H.mkComponent
+      { initialState: const { moduleIndex
+                            , groupingMode
+                            , moduleNames
+                            }
+      , render
+      , eval: H.mkEval $ H.defaultEval { handleAction = handleAction
+                                       , handleQuery = handleQuery
+                                       }
+      }
+  where
+    moduleNames = Array.sort $ Array.fromFoldable $ foldr Set.union mempty moduleIndex
+
+
+handleAction
+ :: forall o
+ .  Action
+ -> H.HalogenM State Action () o Aff Unit
+handleAction (ToggleGrouping groupingMode) = do
+  H.modify_ (_groupingMode .~ groupingMode)
+
+  H.liftEffect do
+    window <- HTML.window
+    localStorage <- Window.localStorage window
+
+    if groupingMode == GroupByPackage
+    then Storage.setItem    config.groupModulesItem "true" localStorage
+    else Storage.removeItem config.groupModulesItem        localStorage
+
+
+handleQuery
+  :: forall a i
+  .  Query a
+  -> H.HalogenM State i () Action Aff (Maybe a)
+handleQuery (UpdateModuleGrouping next) = do
+  oldGroupingMode <- H.get <#> _.groupingMode
+  newGroupingMode <- H.liftEffect loadGroupingModeFromLocalStorage
+  when (oldGroupingMode /= newGroupingMode) do
+    H.modify_ (_groupingMode .~ newGroupingMode)
+  pure Nothing
+
+
+render
+  :: forall m
+  .  State
+  -> H.ComponentHTML Action () m
+render { moduleIndex, groupingMode, moduleNames } =
+
+  HH.div [ HP.classes [ wrap "col", wrap "col--aside" ] ]
+
+  [ HH.h3_ [ HH.text "Modules" ]
+  , HH.input [ HP.id_ "group-modules__input"
+             , HP.type_ HP.InputCheckbox
+             , HP.checked (groupingMode == GroupByPackage)
+             , HE.onChecked $ Just <<< ToggleGrouping <<< isCheckedToGroupingMode
+             ]
+
+  , HH.text " "
+  , HH.label [ HP.for "group-modules__input"
+             , HP.id_ "group-modules__label"
+             ]
+    [ HH.text " GROUP BY PACKAGE" ]
+
+  , HH.ul_ $ if groupingMode == GroupByPackage
+             then renderPackageEntry <$> packageList
+             else renderModuleName <$> moduleNames
+  ]
+  where
+
+    renderPackageEntry (packageName /\ modules) =
+      HH.li [ HP.classes [ wrap "li-package" ] ]
+      [ HH.details_
+        [ HH.summary_ [ HH.text packageName ]
+        , HH.ul_ $ Set.toUnfoldable modules <#> renderModuleName
+        ]
+      ]
+
+    renderModuleName moduleName =
+      HH.li_
+      [ HH.a [ HP.href (moduleName <> ".html") ]
+        [ HH.text moduleName ]
+      ]
+
+    packageList :: Array (String /\ Set ModuleName)
+    packageList = Map.toUnfoldable moduleIndex
+
+
+-- | Decide whether to group modules by package in the sidebar, using localStorage.
+loadGroupingModeFromLocalStorage :: Effect GroupingMode
+loadGroupingModeFromLocalStorage = do
+  window <- HTML.window
+  localStorage <- Window.localStorage window
+  mbGroupModules <- Storage.getItem config.groupModulesItem localStorage
+  pure $ if isJust mbGroupModules then GroupByPackage else DontGroup
+
+
+-- | Convert checkbox status to sidebar mode
+isCheckedToGroupingMode :: Boolean -> GroupingMode
+isCheckedToGroupingMode = if _ then GroupByPackage else DontGroup
+
+
+-- Some optics:
+
+_groupingMode :: forall a b rest.  (a -> b) -> { groupingMode :: a | rest } -> { groupingMode :: b | rest }
+_groupingMode = prop (SProxy :: SProxy "groupingMode")

src/Docs/Search/Config.purs

@@ -7,6 +7,9 @@ config ::
   { declIndexDirectory :: String
   , mkIndexPartLoadPath :: Int -> String
   , mkIndexPartPath :: Int -> String
+  , moduleIndexPath :: String
+  , moduleIndexLoadPath :: String
+  , groupModulesItem :: String
   , packageInfoPath :: String
   , packageInfoLoadPath :: String
   , mkShapeScriptPath :: String -> String
@@ -43,9 +46,13 @@ config =
     \(partId :: Int) -> "html/index/declarations/" <> show partId <> ".js"
   , mkIndexPartLoadPath:
     \(partId :: Int) -> "./index/declarations/" <> show partId <> ".js"
-  , packageInfoPath: "generated-docs/html/index/packages.json"
-  -- ^ Path to package index.
-  , packageInfoLoadPath: "./index/packages.json"
+  , moduleIndexPath: "generated-docs/html/index/modules.js"
+  , moduleIndexLoadPath: "./index/modules.js"
+  -- ^ Used to load mode index to the browser scope.
+  , groupModulesItem: "PureScriptDocsSearchGroupModules"
+  -- ^ localStorage key to save sidebar checkbox value to.
+  , packageInfoPath: "generated-docs/html/index/packages.js"
+  , packageInfoLoadPath: "./index/packages.js"
   -- ^ Used to load package index to the browser scope.
   , resultsCount: 25
   -- ^ How many results to show by default?