0 | module Idris.Doc.HTML
  1 |
  2 | import Core.Context
  3 | import Core.Directory
  4 |
  5 | import Data.String
  6 | import Data.SortedMap
  7 |
  8 | import Libraries.Text.PrettyPrint.Prettyprinter
  9 | import Libraries.Text.PrettyPrint.Prettyprinter.Render.HTML
 10 | import Libraries.Text.PrettyPrint.Prettyprinter.SimpleDocTree
 11 |
 12 | import Idris.Doc.Annotations
 13 | import Idris.Package.Types
 14 | import Idris.Pretty
 15 | import Idris.Version
 16 |
 17 | %default covering
 18 |
 19 | getNS : Name -> String
 20 | getNS (NS ns _) = show ns
 21 | getNS _ = ""
 22 |
 23 | hasNS : Name -> Bool
 24 | hasNS (NS {}) = True
 25 | hasNS _ = False
 26 |
 27 | tryCanonicalName : {auto c : Ref Ctxt Defs} ->
 28 |                 FC -> Name -> Core (Maybe Name)
 29 | tryCanonicalName fc n with (hasNS n)
 30 |   tryCanonicalName fc n | True
 31 |       = do defs <- get Ctxt
 32 |            case !(lookupCtxtName n (gamma defs)) of
 33 |                 [(n, _, _)] => pure $ Just n
 34 |                 _ => pure Nothing
 35 |   tryCanonicalName fc n | False = pure Nothing
 36 |
 37 | packageInternal : {auto c : Ref Ctxt Defs} ->
 38 |                   Name -> Core Bool
 39 | packageInternal (NS ns _) =
 40 |   do let mi = nsAsModuleIdent ns
 41 |      catch ((const True) <$> nsToSource emptyFC mi) (\_ => pure False)
 42 | packageInternal _ = pure False
 43 |
 44 | addLink : {auto c : Ref Ctxt Defs} ->
 45 |           Maybe Name -> String -> Core String
 46 | addLink Nothing rest = pure rest
 47 | addLink (Just n) rest = do
 48 |   Just cName <- tryCanonicalName emptyFC n
 49 |     | Nothing => pure $ "<span class=\"implicit\">" <+> rest <+> "</span>"
 50 |   True <- packageInternal cName
 51 |     | False => pure $ fastConcat
 52 |                     [ "<span class=\"type resolved\" title=\""
 53 |                     , htmlEscape (show cName)
 54 |                     , "\">"
 55 |                     , rest
 56 |                     , "</span>"
 57 |                     ]
 58 |   pure $ fastConcat
 59 |        [ "<a class=\"type\" href=\""
 60 |        , htmlEscape $ getNS cName
 61 |        , ".html#"
 62 |        , htmlEscape $ show cName
 63 |        , "\">"
 64 |        , rest
 65 |        , "</a>"
 66 |        ]
 67 |
 68 | renderHtml : {auto c : Ref Ctxt Defs} ->
 69 |              SimpleDocTree IdrisDocAnn ->
 70 |              Core String
 71 | renderHtml STEmpty = pure neutral
 72 | renderHtml (STChar ' ') = pure "&ensp;"
 73 | renderHtml (STChar c) = pure $ cast c
 74 | renderHtml (STText _ text) = pure $ htmlEscape text
 75 | renderHtml (STLine _) = pure "<br>"
 76 | renderHtml (STAnn Declarations rest)
 77 |   = pure $ "<dl class=\"decls\">" <+> !(renderHtml rest) <+> "</dl>"
 78 | renderHtml (STAnn (Decl n) rest) = pure $ "<dt id=\"" ++ (htmlEscape $ show n) ++ "\"><code>" <+> !(renderHtml rest) <+> "</code></dt>"
 79 | renderHtml (STAnn DocStringBody rest)
 80 |   = pure $ "<dd>" <+> !(renderHtml rest) <+> "</dd>"
 81 | renderHtml (STAnn UserDocString rest)
 82 |   = pure $ "<pre>" <+> !(renderHtml rest) <+> "</pre>"
 83 | renderHtml (STAnn (Syntax (DCon mn)) rest) = do
 84 |   dcon <- renderHtml rest
 85 |   addLink mn $ "<span class=\"name constructor\">" <+> dcon <+> "</span>"
 86 | renderHtml (STAnn (Syntax (TCon mn)) rest) = do
 87 |   tcon <- renderHtml rest
 88 |   addLink mn $ "<span class=\"name type\">" <+> tcon <+> "</span>"
 89 | renderHtml (STAnn (Syntax (Fun n)) rest) = do
 90 |   fun <- renderHtml rest
 91 |   addLink (Just n) $ "<span class=\"name function\">" <+> fun <+> "</span>"
 92 | renderHtml (STAnn (Syntax Keyword) rest) = do
 93 |   key <- renderHtml rest
 94 |   pure $ "<span class=\"keyword\">" <+> key <+> "</span>"
 95 | renderHtml (STAnn (Syntax Bound) rest) = do
 96 |   bnd <- renderHtml rest
 97 |   pure $ "<span class=\"boundvar\">" <+> bnd <+> "</span>"
 98 | renderHtml (STAnn Header rest) = do
 99 |   resthtml <- renderHtml rest
100 |   pure $ "<b>" <+> resthtml <+> "</b>"
101 | renderHtml (STAnn ann rest) = do
102 |   resthtml <- renderHtml rest
103 |   pure $ "<!-- ann ignored START -->" ++ resthtml ++ "<!-- ann END -->"
104 | renderHtml (STConcat docs) = pure $ fastConcat !(traverse renderHtml docs)
105 |
106 | removeNewlinesFromDeclarations : SimpleDocTree IdrisDocAnn -> SimpleDocTree IdrisDocAnn
107 | removeNewlinesFromDeclarations = go False
108 |   where
109 |     go : Bool -> SimpleDocTree IdrisDocAnn -> SimpleDocTree IdrisDocAnn
110 |     go False l@(STLine i) = l
111 |     go True l@(STLine i) = STEmpty
112 |     go ignoring (STConcat docs) = STConcat $ map (go ignoring) docs
113 |     go _ (STAnn Declarations rest) = STAnn Declarations $ go True rest
114 |     go _ (STAnn ann rest) = STAnn ann $ go False rest
115 |     go _ doc = doc
116 |
117 | docDocToHtml : {auto c : Ref Ctxt Defs} ->
118 |                Doc IdrisDocAnn ->
119 |                Core String
120 | docDocToHtml doc =
121 |   let dt = SimpleDocTree.fromStream $ layoutUnbounded doc in
122 |       renderHtml $ removeNewlinesFromDeclarations dt
123 |
124 | htmlPreamble : String -> String -> String -> String
125 | htmlPreamble title root class =
126 |   let title       = htmlEscape title in
127 |   let cssID       = "preferredStyle" in
128 |   let cssSelectID = "selectPreferredStyle" in
129 |   let cssDefault  = "default" in
130 |   let cssLocalKey = "stylefile" in
131 |   """
132 |   <!DOCTYPE html><html lang="en">
133 |
134 |   <head>
135 |     <meta charset="utf-8">
136 |     <title>\{title}</title>
137 |     <link rel="stylesheet" type="text/css" id="\{cssID}" href="\{root}\{cssDefault}.css">
138 |     <script>
139 |       /* Updates the stylesheet to use the preferred one.
140 |          Note that we set the link to root ++ sourceLoc because the config
141 |          is shared across the whole website, so the root may differ from
142 |          page to page.
143 |       */
144 |       function setStyleSource (sourceLoc) {
145 |         document.getElementById("\{cssID}").href = "\{root}" + sourceLoc + ".css";
146 |         document.getElementById("\{cssSelectID}").value = sourceLoc;
147 |       }
148 |       /* Initialises the preferred style sheet:
149 |          1. if there is a stored value then use that
150 |             otherwise select the default
151 |          2. set both the css link href & the drop down menu selected option
152 |       */
153 |       function initStyleSource () {
154 |         var preferredStyle = localStorage.getItem("\{cssLocalKey}");
155 |         if (preferredStyle !== null) {
156 |           setStyleSource(preferredStyle);
157 |         } else {
158 |           setStyleSource("\{cssDefault}");
159 |         };
160 |       }
161 |       function saveStyleSource (preferredStyle) {
162 |         localStorage.\{cssLocalKey} = preferredStyle;
163 |       }
164 |       </script>
165 |   </head>
166 |
167 |   <body class="\{class}">
168 |   <header>
169 |     <strong>Idris2Doc</strong> : \{title}
170 |     <nav><a href="\{root}index.html">Index</a>
171 |
172 |     <select id="\{cssSelectID}">
173 |       \{unlines $ flip map cssFiles $ \ css =>
174 |          #"<option value="\#{css.filename}">\#{css.stylename}</option>"#
175 |       }
176 |     </select>
177 |     </nav>
178 |
179 |     <script>
180 |     /* We start by initialising the style source */
181 |     initStyleSource();
182 |
183 |     /* This listens for changes on the drop down menu and updates the
184 |        css used for the current page when a selection is made.
185 |     */
186 |     document.getElementById("\{cssSelectID}").addEventListener("change", function(){
187 |       var selected = this.options[this.selectedIndex].value; /* the option chosen */
188 |       setStyleSource (selected);
189 |       saveStyleSource (selected);
190 |     });
191 |   </script>
192 |
193 |   </header>
194 |   <div class="container">
195 |   """
196 |
197 | htmlFooter : String
198 | htmlFooter = "</div><footer>Produced by Idris 2 version " ++ (showVersion True version) ++ "</footer></body></html>"
199 |
200 | export
201 | renderDocIndex : PkgDesc -> SortedMap ModuleIdent String -> String
202 | renderDocIndex pkg moddocstrs = fastConcat $
203 |   [ htmlPreamble (name pkg) "" "index"
204 |   , "<h1>Package ", name pkg, " - Namespaces</h1>"
205 |   , "<ul class=\"names\">"] ++
206 |   (map (\x => moduleLink x moddocstrs) $ (modules pkg)) ++
207 |   [ "</ul>"
208 |   , htmlFooter
209 |   ]
210 |     where
211 |       moduleLink : (ModuleIdent, String) -> SortedMap ModuleIdent String -> String
212 |       moduleLink (mod, filename) moddocstrs =
213 |         let cmoddocstr  = case lookup mod moddocstrs of
214 |                             Nothing          => ""
215 |                             Just cmoddocstr' => unlines $ takeWhile (/= "") $ lines $ cmoddocstr'
216 |         in """
217 |            <li>
218 |              <div class="index-wrapper">
219 |                <div class="index-namespace-url">
220 |                  <a class="code" href="docs/\{show mod}.html">\{show mod}</a>
221 |                </div>
222 |                <div class="index-namespace-doc">
223 |                  \{cmoddocstr}
224 |                </div>
225 |              </div>
226 |            </li>
227 |            """
228 |
229 | preserveLayout : String -> String
230 | preserveLayout d = "<pre>" ++ d ++ "</pre>"
231 |
232 | export
233 | renderModuleDoc : {auto c : Ref Ctxt Defs} ->
234 |                   ModuleIdent ->
235 |                   Maybe String -> -- module description
236 |                   Maybe (List (Doc IdrisDocAnn)) -> -- module re-exports
237 |                   Maybe (Doc IdrisDocAnn) -> -- module definitions
238 |                   Core String
239 | renderModuleDoc mod modDoc modReexports allModuleDocs =
240 |   let mdoc = maybe "" (preserveLayout . htmlEscape) modDoc
241 |       mexp = maybe "" vcat modReexports
242 |   in pure $ fastConcat
243 |   [ htmlPreamble (show mod) "../" "namespace"
244 |   , "<div id=\"module-header\">"
245 |   , "<h1>", show mod, "</h1>"
246 |   , mdoc
247 |   , "</div>"
248 |   , maybe "" (const "<h2>Reexports</h2>") modReexports
249 |   , "<code>", !(docDocToHtml mexp), "</code>"
250 |   , maybe "" (const "<h2>Definitions</h2>") allModuleDocs
251 |   , !(docDocToHtml $ fromMaybe "" allModuleDocs)
252 |   , htmlFooter
253 |   ]
254 |