Add basic search functionality

.gitmodules

 [submodule "data/cleandoc-default/modules/clean-highlighter"]
 	path = data/cleandoc-default/modules/clean-highlighter
-	url = git@github.com:clean-cloogle/clean-highlighter
+	url = https://github.com/clean-cloogle/clean-highlighter
+[submodule "data/cleandoc-default/modules/lunr.js"]
+	path = data/cleandoc-default/modules/lunr.js
+	url = https://github.com/olivernn/lunr.js

data/cleandoc-default/css/style.css

@@ -27,17 +27,34 @@ body, html {
 	width: 15%;
 }
 
+#sidebar > div {
+	box-sizing: border-box;
+	padding: 1em;
+}
+
 #toc {
 	height: 70%;
 	outline: 1px solid black;
 	overflow: auto;
 }
 
+#toc h1 {
+	margin: 0;
+}
+
+#toc ul {
+	padding-left: 1.5em;
+}
+
 #search {
 	height: 30%;
 	overflow: auto;
 }
 
+#search-results ul {
+	padding-left: 1.5em;
+}
+
 #content {
 	left: 20%;
 	padding: 0 1em;

data/cleandoc-default/js/cleandoc.js

+var lunr_items;
+var lunr_index;
+function build_lunr(items) {
+	lunr_items = items;
+	lunr_index = lunr(function(){
+		this.field('name');
+		this.field('description');
+
+		for (var i in items) {
+			items[i].id = i;
+			this.add(items[i]);
+		}
+	});
+}
+
+function make_relative_url(url) {
+	var current_path = this_relative_url.split('/').reverse();
+	var new_url = '';
+	for (var i = 0; i < current_path.length-1; i++)
+		new_url += '../';
+	new_url += url;
+	return new_url;
+}
+
 (function(){
 	/* Highlight Clean code */
 	let codes = document.getElementsByClassName('clean-code');
@@ -32,4 +56,31 @@
 			head.onclick();
 		}
 	}
+
+	/* search field */
+	let searchfield = document.getElementById('search-field');
+	let searchresults = document.getElementById('search-results').querySelector('ul');
+	searchfield.oninput = function () {
+		searchresults.innerHTML = '';
+
+		if (this.value == '')
+			return;
+
+		var results = lunr_index.search(this.value);
+
+		if (results.length == 0) {
+			searchresults.innerHTML = '<em>no results</em>';
+			return;
+		}
+
+		for (let i in results) {
+			let elem = lunr_items[results[i].ref];
+			let li = document.createElement('li');
+			let a = document.createElement('a');
+			a.href = make_relative_url('mod/' + elem.module + '.html#' + elem.htmlid);
+			a.innerHTML = '<code>' + elem.name + '</code> in <code>' + elem.module + '</code>';
+			li.appendChild(a);
+			searchresults.appendChild(li);
+		}
+	};
 })();

lunr.js @ 3a003702

+Subproject commit 3a003702ac1b561e5635ea5de1670f908f5410a7

src/Clean/Doc/ModuleCollection.dcl

@@ -2,7 +2,8 @@ definition module Clean.Doc.ModuleCollection
 
 from StdOverloaded import class <
 
-from Clean.Doc import :: ClassDoc, :: FunctionDoc, :: ModuleDoc, :: TypeDoc
+from Clean.Doc import :: ClassDoc, :: FunctionDoc, :: ModuleDoc, :: TypeDoc,
+	class docDescription
 from Clean.ModuleFinder import :: ModuleFindingOptions
 from Data.Error import :: MaybeError
 from Data.Maybe import :: Maybe
@@ -26,11 +27,16 @@ instance < (Described e d)
 	, mod_functions :: ![DescribedFunction]
 	}
 
-:: DescribedTypeDef :== Described () TypeDoc
+:: DescribedTypeDef :== Described TypeDefDescription TypeDoc
+:: TypeDefDescription = TypeDefDescription
 
-:: DescribedClass :== Described [DescribedFunction] ClassDoc
+:: DescribedClass :== Described ClassDescription ClassDoc
+:: ClassDescription =
+	{ class_members :: ![DescribedFunction]
+	}
 
-:: DescribedFunction :== Described () FunctionDoc
+:: DescribedFunction :== Described FunctionDescription FunctionDoc
+:: FunctionDescription = FunctionDescription
 
 collectModule :: !ModuleFindingOptions !FilePath !*World
 	-> *(!MaybeError String DescribedModule, !*World)

src/Clean/Doc/ModuleCollection.icl

@@ -59,7 +59,7 @@ where
 	collectTypeDef cc pd=:(PD_Type ptd) =
 		{ name = ptd.td_ident.id_name
 		, repr = Just (cpp pd)
-		, elem = ()
+		, elem = TypeDefDescription
 		, doc  = case parseDoc <$> getComment pd cc of
 			Just (Right (doc,_)) -> Just doc
 			_                    -> Nothing
@@ -69,7 +69,9 @@ where
 	collectClass cc pd=:(PD_Class cd members) =
 		{ name = cd.class_ident.id_name
 		, repr = Just (cpp pd)
-		, elem = [collectFunction cc m \\ m <- members]
+		, elem =
+			{ class_members = [collectFunction cc m \\ m <- members]
+			}
 		, doc  = case parseDoc <$> getComment pd cc of
 			Just (Right (doc,_)) -> Just doc
 			_                    -> Nothing
@@ -79,7 +81,7 @@ where
 	collectFunction cc pd=:(PD_TypeSpec _ id _ _ _) =
 		{ name = id.id_name
 		, repr = Just (cpp pd)
-		, elem = ()
+		, elem = FunctionDescription
 		, doc  = case parseDoc <$> getComment pd cc of
 			Just (Right (doc,_)) -> Just doc
 			_                    -> Nothing

src/Clean/Doc/ModuleCollection/HTML.dcl

@@ -8,9 +8,9 @@ from Clean.Doc.ModuleCollection import
 	:: Described, :: DescribedModule,
 	:: ModuleCollection, :: ModuleDescription
 
-:: HTMLSite
+:: WebSite
 
-generateHTML :: !ModuleCollection -> HTMLSite
+generateHTML :: !ModuleCollection -> WebSite
 
 /**
  * Write a HTML site to disk.
@@ -21,4 +21,4 @@ generateHTML :: !ModuleCollection -> HTMLSite
  * @param The site
  * @result A list of errors occurred, in human-readable format
  */
-writeHTMLSite :: !FilePath !HTMLSite !*World -> *(![String], !*World)
+writeHTMLSite :: !FilePath !WebSite !*World -> *(![String], !*World)

src/Clean/Doc/ModuleCollection/HTML.icl

@@ -19,34 +19,44 @@ import System.Environment
 import System.File
 import System.FilePath
 import Text => qualified join
+import Text.GenJSON
 import Text.HTML
 
 import Clean.Doc.ModuleCollection
+import Clean.Doc.ModuleCollection.Index => qualified :: IndexItem{name}
 
-:: HTMLSite :== [(FilePath, HtmlTag)]
+:: WebSite :== [(FilePath, String)]
 
-generateHTML :: !ModuleCollection -> HTMLSite
-generateHTML mcoll = map (\(fp,html) -> (fp,finalizeHTML fp html)) $
-	[ ("index.html", Text "")
-	: map moduleFile mcoll
-	]
+generateHTML :: !ModuleCollection -> WebSite
+generateHTML mcoll =
+	[("js/lunr-index.js", "build_lunr(" +++ (toString $ toJSON $ indexModuleCollection mcoll) +++ ");")] ++
+	map (\(fp,html) -> (fp,finalizeHTML fp html))
+		[ ("index.html", Text "")
+		: map moduleFile mcoll
+		]
 where
-	finalizeHTML :: FilePath HtmlTag -> HtmlTag
-	finalizeHTML fp html = HtmlTag [LangAttr "en"]
+	finalizeHTML :: FilePath HtmlTag -> String
+	finalizeHTML fp html = (+++) "<!DOCTYPE html>" $ toString $ HtmlTag [LangAttr "en"]
 		[ HeadTag []
 			[ TitleTag [] [Text "Documentation"]
 			, MetaTag [CharsetAttr "utf-8"]
 			, LinkTag [RelAttr "stylesheet", TypeAttr "text/css", HrefAttr (relativePath "modules/clean-highlighter/clean.css")]
 			, LinkTag [RelAttr "stylesheet", TypeAttr "text/css", HrefAttr (relativePath "css/style.css")]
+			, ScriptTag [] [Text ("var this_relative_url = '" +++ fp +++ "'")]
 			, ScriptTag [DeferAttr "defer", SrcAttr (relativePath "modules/clean-highlighter/clean.js")] []
 			, ScriptTag [DeferAttr "defer", SrcAttr (relativePath "js/cleandoc.js")] []
+			, ScriptTag [DeferAttr "defer", SrcAttr (relativePath "modules/lunr.js/lunr.js")] []
+			, ScriptTag [DeferAttr "defer", SrcAttr (relativePath "js/lunr-index.js")] []
 			]
 		, BodyTag []
 			[ DivTag [IdAttr "container"]
 				[ DivTag [IdAttr "content"] [html]
 				, DivTag [IdAttr "sidebar"]
 					[ DivTag [IdAttr "toc"] [H1Tag [] [Text "Documentation"], UlTag [] (map sidebarLink (sort mcoll))]
-					, DivTag [IdAttr "search"] [Text "(search functionality not implemented yet)"]
+					, DivTag [IdAttr "search"]
+						[ InputTag [IdAttr "search-field", TypeAttr "text", PlaceholderAttr "search"]
+						, DivTag [IdAttr "search-results"] [UlTag [] []]
+						]
 					]
 				]
 			]
@@ -67,7 +77,7 @@ where
 	moduleFile m = ("mod" </> m.name +++ ".html", html)
 	where
 		html = DivTag [] $ catMaybes
-			[ Just $ H1Tag [IdAttr "mod_name"] [Text m.name]
+			[ Just $ H1Tag [IdAttr ("mod-" +++ m.name)] [Text m.name]
 			, DivTag [IdAttr "mod_description"] <$> pure <$> Text <$> (docDescription =<< m.doc)
 			, Just $ DivTag [IdAttr "type_defs"] typedefs
 			, Just $ DivTag [IdAttr "classes"] classes
@@ -119,7 +129,7 @@ where
 		, DivTag [ClassAttr "collapsable-body"] [html body]
 		]
 
-writeHTMLSite :: !FilePath !HTMLSite !*World -> *(![String], !*World)
+writeHTMLSite :: !FilePath !WebSite !*World -> *(![String], !*World)
 writeHTMLSite root site w
 # (assets,w) = findAssetsDirectory w
 | isError assets = ([fromError assets], w)
@@ -128,6 +138,7 @@ writeHTMLSite root site w
 # (errs,w) = syncDirectory
 	(\fp fi
 		| endsWith "node_modules" fp -> False
+		| indexOf "lunr.js" fp >= 0 && not (endsWith "lunr.js" fp) -> False
 		| fi.directory               -> True
 		| endsWith ".js"  fp         -> True
 		| endsWith ".css" fp         -> True
@@ -136,12 +147,12 @@ writeHTMLSite root site w
 # (errs2,w) = mapSt (uncurry handle) site w
 = (errs ++ flatten errs2,w)
 where
-	handle :: !FilePath !HtmlTag !*World -> *(![String], !*World)
+	handle :: !FilePath !String !*World -> *(![String], !*World)
 	handle fp contents w
 	# fp = root </> fp
 	# (err,w) = ensureDirectoryExists (takeDirectory fp) w
 	| isError err = ([snd (fromError err)], w)
-	# (err,w) = writeFile fp ("<!DOCTYPE html>" <+ contents) w
+	# (err,w) = writeFile fp contents w
 	| isError err = ([toString (fromError err)], w)
 	= ([], w)
 

src/Clean/Doc/ModuleCollection/Index.dcl

+definition module Clean.Doc.ModuleCollection.Index
+
+from Clean.Doc import class docDescription
+from Data.Maybe import :: Maybe
+from Text.GenJSON import :: JSONNode, generic JSONEncode
+
+from Clean.Doc.ModuleCollection import :: Described, :: ModuleDescription,
+	:: ModuleDoc, :: DescribedModule, :: ModuleCollection
+
+:: IndexItem =
+	{ modul       :: String
+	, name        :: String
+	, kind        :: IndexItemKind
+	, description :: Maybe String
+	}
+
+:: IndexItemKind
+	= IIK_Module
+	| IIK_TypeDef
+	| IIK_Class
+	| IIK_Function
+
+derive JSONEncode IndexItem
+
+indexModuleCollection :: ModuleCollection -> [IndexItem]

src/Clean/Doc/ModuleCollection/Index.icl

+implementation module Clean.Doc.ModuleCollection.Index
+
+import StdMisc
+import StdString
+
+import Clean.Doc
+import Control.Monad
+from Data.Func import $, instance Functor ((->) a)
+import Data.Functor
+import Data.List
+import Data.Maybe
+import Data.Tuple
+import Text.GenJSON
+
+import Clean.Doc.ModuleCollection
+
+JSONEncode{|IndexItemKind|} _ iik = [JSONString case iik of
+	IIK_Module   -> "module"
+	IIK_TypeDef  -> "typedef"
+	IIK_Class    -> "class"
+	IIK_Function -> "function"]
+
+JSONEncode{|IndexItem|} _ ii = [JSONObject $ catMaybes
+	[ Just ("module", JSONString ii.modul)
+	, Just ("name",   JSONString ii.IndexItem.name)
+	, Just ("htmlid", JSONString (kind +++ "-" +++ ii.IndexItem.name))
+	, tuple "description" <$> JSONString <$> ii.IndexItem.description
+	]]
+where
+	kind = case ii.kind of
+		IIK_Module   -> "mod"
+		IIK_TypeDef  -> "td"
+		IIK_Class    -> "class"
+		IIK_Function -> "fun"
+
+class kind a :: a -> IndexItemKind
+
+instance kind ModuleDescription   where kind _ = IIK_Module
+instance kind TypeDefDescription  where kind _ = IIK_TypeDef
+instance kind ClassDescription    where kind _ = IIK_Class
+instance kind FunctionDescription where kind _ = IIK_Function
+
+indexModuleCollection :: ModuleCollection -> [IndexItem]
+indexModuleCollection mcoll = concatMap indexModule mcoll
+
+indexModule :: DescribedModule -> [IndexItem]
+indexModule mod =
+	[ { modul       = mod.Described.name
+	  , name        = mod.Described.name
+	  , kind        = IIK_Module
+	  , description = docDescription =<< mod.doc
+	  }
+	: map indexTypeDef  mod.elem.mod_type_defs ++
+	  map indexClass    mod.elem.mod_classes ++
+	  map indexFunction mod.elem.mod_functions
+	]
+where
+	//index :: (Described e d) -> IndexItem
+	index d =
+		{ modul       = mod.Described.name
+		, name        = d.Described.name
+		, kind        = undef
+		, description = docDescription =<< d.doc
+		}
+
+	indexTypeDef  dtd = {index dtd & kind=IIK_TypeDef}
+	indexClass    dc  = {index dc  & kind=IIK_Class}
+	indexFunction df  = {index df  & kind=IIK_Function}