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