fix: render submodules in html docs (#1242)

* fix: render submodules in html docs

* fix: also render deeply nested modules

* feat: no prefixes in nested submodule doc rendering

* fix:  fix text alignment of module index for sdl

* feat: make submodules expandable

core/Statistics.carp

@@ -17,6 +17,7 @@
     quartiles (Array Double),
     iqr Double
   ])
+  (hidden Summary)
 
   (doc mean "Compute the mean of the samples data.")
   (defn mean [data]

core/Test.carp

@@ -2,6 +2,7 @@
 
 (defmodule Test
   (deftype State [passed Int, failed Int])
+  (hidden State)
   (use Color.Id)
   (hidden handler)
   (defn handler [state expected actual descr what op]

docs/core/carp_style.css

@@ -18,10 +18,10 @@ a:hover {
 }
 
 .logo {
-    text-align: right;
     float: right;
-    width: 150px;
     font-family: "Hasklig", "Lucida Console", monospace;
+    width: 20%;
+    margin-right: 10%;
 }
 
 .logo img {
@@ -29,6 +29,18 @@ a:hover {
     margin-bottom: 1em;
 }
 
+details summary {
+  cursor: pointer;
+}
+
+details summary > * {
+  display: inline;
+}
+
+.index {
+  text-align: left;
+}
+
 .args {
   background-color: #eee;
   padding: 3px;
@@ -42,6 +54,7 @@ ul {
     list-style-type: none;
     font-family: "Hasklig", "Lucida Console", monospace;
     line-height: 1.4em;
+    padding-left: 1em;
 }
 
 .title {
@@ -49,9 +62,13 @@ ul {
 }
 
 .content {
-    margin: 3em auto auto auto;
-    width: 80%;
+    width: 100%;
+}
+
+.module {
     max-width: 800px;
+    margin: auto;
+    margin-top: 5em;
 }
 
 h1 {
@@ -75,20 +92,6 @@ h3 {
     margin: 3.5em 0em 0em 0em;
 }
 
-.deprecation-notice {
-  background-color: #f99;
-  text-transform: uppercase;
-  float: right;
-  padding: 5px;
-  margin: -5px;
-}
-
-.deprecation-text {
-  background-color: #f99;
-  padding-left: 5px;
-  padding-right: 5px;
-}
-
 .sig {
     font-family: "Hasklig", "Source Code Pro", "Lucida Console", monospace;
 }

docs/sdl/carp_style.css

@@ -18,10 +18,10 @@ a:hover {
 }
 
 .logo {
-    text-align: right;
     float: right;
-    width: 150px;
     font-family: "Hasklig", "Lucida Console", monospace;
+    width: 20%;
+    margin-right: 10%;
 }
 
 .logo img {
@@ -29,6 +29,18 @@ a:hover {
     margin-bottom: 1em;
 }
 
+details summary {
+  cursor: pointer;
+}
+
+details summary > * {
+  display: inline;
+}
+
+.index {
+  text-align: left;
+}
+
 .args {
   background-color: #eee;
   padding: 3px;
@@ -42,6 +54,7 @@ ul {
     list-style-type: none;
     font-family: "Hasklig", "Lucida Console", monospace;
     line-height: 1.4em;
+    padding-left: 1em;
 }
 
 .title {
@@ -49,9 +62,13 @@ ul {
 }
 
 .content {
-    margin: 3em auto auto auto;
-    width: 80%;
+    width: 100%;
+}
+
+.module {
     max-width: 800px;
+    margin: auto;
+    margin-top: 5em;
 }
 
 h1 {

src/Obj.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Obj where
 
@@ -228,6 +228,10 @@ isTypeDef (XObj (Lst (XObj (Deftype _) _ _ : _)) _ _) = True
 isTypeDef (XObj (Lst (XObj (DefSumtype _) _ _ : _)) _ _) = True
 isTypeDef _ = False
 
+isMod :: XObj -> Bool
+isMod (XObj (Mod _ _) _ _) = True
+isMod _ = False
+
 -- | This instance is needed for the dynamic Dictionary
 instance Ord Obj where
   compare (Str a) (Str b) = compare a b

src/RenderDocs.hs

@@ -37,9 +37,11 @@ saveDocsForEnvs ctx pathsAndEnvBinders =
   let dir = projectDocsDir ctx
       title = projectTitle ctx
       generateIndex = projectDocsGenerateIndex ctx
-      allEnvNames = fmap (getModuleName . fst . getEnvAndMetaFromBinder . snd) pathsAndEnvBinders
+      dependencies = getDependenciesForEnvs (Prelude.map (\(p, b) -> (p, fst (getEnvAndMetaFromBinder b))) pathsAndEnvBinders)
+      pathsAndEnvBinders' = pathsAndEnvBinders ++ dependencies
+      allEnvNames = fmap fst pathsAndEnvBinders'
    in do
-        mapM_ (saveDocsForEnvBinder ctx allEnvNames) pathsAndEnvBinders
+        mapM_ (saveDocsForEnvBinder ctx allEnvNames) pathsAndEnvBinders'
         when
           generateIndex
           ( writeFile
@@ -47,6 +49,21 @@ saveDocsForEnvs ctx pathsAndEnvBinders =
               (projectIndexPage ctx allEnvNames)
           )
         putStrLn ("Generated docs to '" ++ dir ++ "'")
+  where
+    getDependenciesForEnvs = Prelude.concat . Prelude.map getEnvDependencies
+    getEnvDependencies (SymPath ps p, e) =
+      let envs =
+            Prelude.map
+              (\(n, b) -> (SymPath (ps ++ [p]) n, b))
+              ( Prelude.filter
+                  (\(_, Binder _ x) -> isMod x)
+                  ( Prelude.filter
+                      shouldEmitDocsForBinder
+                      (Map.toList (envBindings e))
+                  )
+              )
+       in envs
+            ++ getDependenciesForEnvs (Prelude.map (\(n, Binder _ (XObj (Mod env _) _ _)) -> (n, env)) envs)
 
 -- | This function expects a binder that contains an environment, anything else is a runtime error.
 getEnvAndMetaFromBinder :: Binder -> (Env, MetaData)
@@ -55,7 +72,7 @@ getEnvAndMetaFromBinder envBinder =
     Binder meta (XObj (Mod env _) _ _) -> (env, meta)
     _ -> error "Binder's not a module. This should be detected in 'commandSaveDocsInternal'."
 
-projectIndexPage :: Project -> [String] -> String
+projectIndexPage :: Project -> [SymPath] -> String
 projectIndexPage ctx moduleNames =
   let logo = projectDocsLogo ctx
       url = projectDocsURL ctx
@@ -91,17 +108,17 @@ headOfPage css =
 getModuleName :: Env -> String
 getModuleName env = fromMaybe "Global" (envModuleName env)
 
-saveDocsForEnvBinder :: Project -> [String] -> (SymPath, Binder) -> IO ()
+saveDocsForEnvBinder :: Project -> [SymPath] -> (SymPath, Binder) -> IO ()
 saveDocsForEnvBinder ctx moduleNames (envPath, envBinder) =
   do
-    let SymPath _ moduleName = envPath
+    let moduleName = show envPath
         dir = projectDocsDir ctx
         fullPath = dir </> moduleName ++ ".html"
         string = renderHtml (envBinderToHtml envBinder ctx (show envPath) moduleNames)
     createDirectoryIfMissing False dir
     writeFile fullPath string
 
-envBinderToHtml :: Binder -> Project -> String -> [String] -> H.Html
+envBinderToHtml :: Binder -> Project -> String -> [SymPath] -> H.Html
 envBinderToHtml envBinder ctx moduleName moduleNames =
   let (env, meta) = getEnvAndMetaFromBinder envBinder
       title = projectTitle ctx
@@ -126,26 +143,42 @@ envBinderToHtml envBinder ctx moduleName moduleNames =
                     --span_ "CARP DOCS FOR"
                     H.div ! A.class_ "title" $ H.toHtml title
                     moduleIndex moduleNames
-                H.h1 (H.toHtml moduleName)
-                H.div ! A.class_ "module-description" $ H.preEscapedToHtml moduleDescriptionHtml
-                mapM_ (binderToHtml . snd) (Prelude.filter shouldEmitDocsForBinder (Map.toList (envBindings env)))
+                H.div ! A.class_ "module" $
+                  do
+                    H.h1 (H.toHtml moduleName)
+                    H.div ! A.class_ "module-description" $ H.preEscapedToHtml moduleDescriptionHtml
+                    mapM_ (binderToHtml moduleName . snd) (Prelude.filter shouldEmitDocsForBinder (Map.toList (envBindings env)))
 
 shouldEmitDocsForBinder :: (String, Binder) -> Bool
 shouldEmitDocsForBinder (_, Binder meta _) =
   not (metaIsTrue meta "hidden")
 
-moduleIndex :: [String] -> H.Html
+moduleIndex :: [SymPath] -> H.Html
 moduleIndex moduleNames =
-  H.div ! A.class_ "index" $
-    H.ul $
-      mapM_ moduleLink moduleNames
+  H.div ! A.class_ "index" $ grouped moduleNames
+  where
+    grouped names = H.ul $ mapM_ gen (order names)
+    gen (m, subs) =
+      H.li $
+        if Prelude.null subs
+          then moduleLink m
+          else H.details $
+            do
+              H.summary (moduleLink m)
+              grouped subs
+    order [] = []
+    order (m : mods) =
+      let (isIn, isNotIn) = List.partition (symBelongsToMod m) mods
+       in (m, isIn) : order isNotIn
+    symBelongsToMod (SymPath xs x) (SymPath ys y) =
+      List.isPrefixOf (xs ++ [x]) (ys ++ [y])
 
-moduleLink :: String -> H.Html
-moduleLink name =
-  H.li $ H.a ! A.href (H.stringValue (name ++ ".html")) $ H.toHtml name
+moduleLink :: SymPath -> H.Html
+moduleLink p@(SymPath _ name) =
+  H.a ! A.href (H.stringValue (show p ++ ".html")) $ H.toHtml name
 
-binderToHtml :: Binder -> H.Html
-binderToHtml (Binder meta xobj) =
+binderToHtml :: String -> Binder -> H.Html
+binderToHtml moduleName (Binder meta xobj) =
   let name = getSimpleName xobj
       maybeNameAndArgs = getSimpleNameWithArgs xobj
       description = getBinderDescription xobj
@@ -169,7 +202,9 @@ binderToHtml (Binder meta xobj) =
           H.a ! A.class_ "anchor" ! A.href (H.stringValue ("#" ++ name)) $
             H.h3 ! A.id (H.stringValue name) $
               do
-                H.toHtml name
+                if isMod xobj
+                  then H.a ! A.href (H.stringValue (moduleName ++ "." ++ pretty xobj ++ ".html")) $ H.toHtml (pretty xobj)
+                  else H.toHtml name
                 when isDeprecated $
                   H.span ! A.class_ "deprecation-notice" $
                     H.toHtml ("deprecated" :: String)

src/StartingEnv.hs

@@ -125,7 +125,8 @@ functionModule =
   where
     bindEnv env =
       let Just name = envModuleName env
-       in (name, Binder emptyMeta (XObj (Mod env E.empty) Nothing Nothing))
+          meta = Meta.set "hidden" trueXObj emptyMeta
+       in (name, Binder meta (XObj (Mod env E.empty) Nothing Nothing))
     bindings = Map.fromList (map (bindEnv . generateInnerFunctionModule) [0 .. maxArity])
 
 -- | Each arity of functions need their own module to enable copying and string representation