@@ -0,0 +1,672 @@
1+{-# LANGUAGE PatternGuards #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+
4+-- | Generation of HTML documentation for Idris code
5+module Idris.IdrisDoc (generateDocs) where
6+
7+import Idris.Core.TT (Name (..), sUN, SpecialName (..), OutputAnnotation (..),
8+ TextFormatting (..), txt, str, nsroot)
9+import Idris.Core.Evaluate (ctxtAlist, Def (..), lookupDefAcc,
10+ Accessibility (..), isDConName, isFnName,
11+ isTConName)
12+import Idris.ParseHelpers (opChars)
13+import Idris.AbsSyntax
14+import Idris.Docs
15+import Idris.Docstrings (nullDocstring)
16+
17+import Paths_idris (getDataFileName)
18+
19+import Control.Monad (forM_)
20+import Control.Monad.Trans.Error
21+import Control.Monad.Trans.State.Strict
22+
23+import Data.Maybe
24+
25+import qualified Data.ByteString as BS
26+import qualified Data.ByteString.Lazy as BS2
27+import qualified Data.Text.Encoding as E
28+import qualified Data.List as L
29+import qualified Data.List.Split as LS
30+import qualified Data.Map as M hiding ((!))
31+import qualified Data.Ord (compare)
32+import qualified Data.Set as S
33+import qualified Data.Text as T
34+
35+import System.IO
36+import System.IO.Error
37+import System.FilePath
38+import System.Directory
39+
40+import Cheapskate.Html (renderDoc)
41+import Text.PrettyPrint.Annotated.Leijen (displayDecorated, renderCompact)
42+
43+import Text.Blaze (toValue, contents)
44+import Text.Blaze.Internal (MarkupM (Empty))
45+import Text.Blaze.Html5 ((!), toHtml, preEscapedToHtml)
46+import qualified Text.Blaze.Html5 as H
47+import Text.Blaze.Html5.Attributes as A
48+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
49+import qualified Text.Blaze.Html.Renderer.String as R
50+import Text.Blaze.Renderer.String (renderMarkup)
51+
52+-- ---------------------------------------------------------------- [ Public ]
53+
54+-- | Generates HTML documentation for a series of loaded namespaces
55+-- and their dependencies.
56+generateDocs :: IState -- ^ IState where all necessary information is
57+ -- extracted from.
58+ -> [Name] -- ^ List of namespaces to generate
59+ -- documentation for.
60+ -> FilePath -- ^ The directory to which documentation will
61+ -- be written.
62+ -> IO (Either String ())
63+generateDocs ist nss' out =
64+ do let nss = map toNsName nss'
65+ docs <- fetchInfo ist nss
66+ let (c, io) = foldl (checker docs) (0, return ()) nss
67+ io
68+ if c < length nss
69+ then catchIOError (createDocs ist docs out) (err . show)
70+ else err "No namespaces to generate documentation for"
71+
72+ where checker docs st ns | M.member ns docs = st
73+ checker docs (c, io) ns = (c+1, do prev <- io; warnMissing ns)
74+ warnMissing ns =
75+ putStrLn $ "Warning: Ignoring empty or non-existing namespace '" ++
76+ (nsName2Str ns) ++ "'"
77+
78+-- ----------------------------------------------------------------- [ Types ]
79+
80+type Failable = Either String
81+type NsName = [T.Text]
82+type NsItem = (Name, Maybe Docs, Accessibility)
83+type NsInfo = [NsItem]
84+type NsDict = M.Map NsName NsInfo
85+
86+-- Information stored together with IdrisDoc documentation
87+data DocInfo = DocInfo {
88+ -- Namespaces already documented
89+ namespaces :: S.Set NsName
90+ }
91+
92+-- --------------------------------------------------------------- [ Utility ]
93+
94+-- | Make an error message
95+err :: String -> IO (Failable ())
96+err s = return $ Left s
97+
98+-- | IdrisDoc version
99+version :: String
100+version = "1.0"
101+
102+-- | Converts a Name into a [Text] corresponding to the namespace
103+-- part of a NS Name.
104+toNsName :: Name -- ^ Name to convert
105+ -> NsName
106+toNsName (UN n) = [n]
107+toNsName (NS n ns) = (toNsName n) ++ ns
108+toNsName _ = []
109+
110+
111+-- | Retrieves the namespace part of a Name
112+getNs :: Name -- ^ Name to retrieve namespace for
113+ -> NsName
114+getNs (NS _ ns) = ns
115+getNs _ = []
116+
117+
118+-- | String to replace for the root namespace
119+rootNsStr :: String
120+rootNsStr = "[builtins]"
121+
122+
123+-- | Converts a NsName to string form
124+nsName2Str :: NsName -- ^ NsName to convert
125+ -> String
126+nsName2Str n = if null n then rootNsStr else name n
127+
128+ where name [] = []
129+ name [ns] = str ns
130+ name (ns:nss) = (name nss) ++ ('.' : str ns)
131+
132+-- --------------------------------------------------------- [ Info Fetching ]
133+
134+-- | Fetch info about namespaces and their contents
135+fetchInfo :: IState -- ^ IState to fetch info from
136+ -> [NsName] -- ^ List of namespaces to fetch info for
137+ -> IO NsDict -- ^ Mapping from namespace name to
138+ -- info about its contents
139+fetchInfo ist nss =
140+ do let originNss = S.fromList nss
141+ info <- nsDict ist
142+ let info' = M.map (filter (filterName . (\(n, _, _) -> n))) info
143+ info'' = M.map removeOrphans info'
144+ reachedNss = traceNss info'' originNss S.empty
145+ return $ M.filterWithKey (\k _ -> S.member k reachedNss) info''
146+
147+
148+-- | Removes loose class methods and data constructors,
149+-- leaving them documented only under their parent.
150+removeOrphans :: [NsItem] -- ^ List to remove orphans from
151+ -> [NsItem] -- ^ Orphan-free list
152+removeOrphans list =
153+ let children = S.fromList $ concatMap (names . (\(_, d, _) -> d)) list
154+ in filter ((`S.notMember` children) . (\(n, _, _) -> n)) list
155+
156+ where names (Just (DataDoc _ fds)) = map (\(FD n _ _ _ _) -> n) fds
157+ names (Just (ClassDoc _ _ fds)) = map (\(FD n _ _ _ _) -> n) fds
158+ names _ = []
159+
160+-- | Whether a Name names something which should be documented
161+filterName :: Name -- ^ Name to check
162+ -> Bool -- ^ Predicate result
163+filterName (UN n) | '@':'@':_ <- str n = False
164+filterName (UN _) = True
165+filterName (NS n _) = filterName n
166+filterName _ = False
167+
168+
169+-- | Finds all namespaces indirectly referred by a set of namespaces.
170+-- The NsItems of the namespaces are searched for references.
171+traceNss :: NsDict -- ^ Mappings of namespaces and their contents
172+ -> S.Set NsName -- ^ Set of namespaces to trace
173+ -> S.Set NsName -- ^ Set of namespaces which has been traced
174+ -> S.Set NsName -- ^ Set of namespaces to trace and all traced one
175+traceNss nsd sT sD =
176+ let nsTracer ns | Just nsis <- M.lookup ns nsd = map referredNss nsis
177+ nsTracer _ = [S.empty] -- Ignore
178+ reached = S.unions $ concatMap nsTracer (S.toList sT)
179+ processed = S.union sT sD
180+ untraced = S.difference reached processed
181+ in if S.null untraced then processed
182+ else traceNss nsd untraced processed
183+
184+
185+-- | Gets all namespaces directly referred by a NsItem
186+referredNss :: NsItem -- ^ The name to get all directly
187+ -- referred namespaces for
188+ -> S.Set NsName
189+referredNss (_, Nothing, _) = S.empty
190+referredNss (n, Just d, _) =
191+ let fds = getFunDocs d
192+ ts = concatMap types fds
193+ names = concatMap (extractPTermNames) ts
194+ in S.map getNs $ S.fromList names
195+
196+ where getFunDocs (FunDoc f) = [f]
197+ getFunDocs (DataDoc f fs) = f:fs
198+ getFunDocs (ClassDoc _ _ fs) = fs
199+ types (FD _ _ args t _) = t:(map second args)
200+ second (_, x, _, _) = x
201+
202+
203+-- | Returns an NsDict of containing all known namespaces and their contents
204+nsDict :: IState
205+ -> IO NsDict
206+nsDict ist =
207+ let nameDefList = ctxtAlist $ tt_ctxt ist
208+ adder m (n, _) = do map <- m
209+ doc <- loadDocs ist n
210+ let acc = getAccess ist n
211+ c = [(n, doc, acc)]
212+ return $ M.insertWith (++) (getNs n) c map
213+ in foldl adder (return M.empty) nameDefList
214+
215+
216+-- | Gets the Accessibility for a Name
217+getAccess :: IState -- ^ IState containing accessibility information
218+ -> Name -- ^ The Name to retrieve access for
219+ -> Accessibility
220+getAccess ist n =
221+ let res = lookupDefAcc n False (tt_ctxt ist)
222+ in case res of
223+ [(_, acc)] -> acc
224+ _ -> Public
225+
226+-- | Simple predicate for whether an NsItem has Docs
227+hasDoc :: NsItem -- ^ The NsItem to test
228+ -> Bool -- ^ The result
229+hasDoc (_, Just _, _) = True
230+hasDoc _ = False
231+
232+
233+-- | Predicate saying whether a Name possibly may have docs defined
234+-- Without this, getDocs from Idris.Docs may fail a pattern match.
235+mayHaveDocs :: Name -- ^ The Name to test
236+ -> Bool -- ^ The result
237+mayHaveDocs (UN _) = True
238+mayHaveDocs (NS n _) = mayHaveDocs n
239+mayHaveDocs _ = False
240+
241+
242+-- | Retrieves the Docs for a Name
243+loadDocs :: IState -- ^ IState to extract infomation from
244+ -> Name -- ^ Name to load Docs for
245+ -> IO (Maybe Docs)
246+loadDocs ist n
247+ | mayHaveDocs n = do docs <- runErrorT $ evalStateT (getDocs n) ist
248+ case docs of Right d -> return (Just d)
249+ Left _ -> return Nothing
250+ | otherwise = return Nothing
251+
252+
253+-- | Extracts names referred from a type.
254+-- The covering of all PTerms ensures that we avoid unanticipated cases,
255+-- though all of them are not needed. The author just did not know which!
256+-- TODO: Remove unnecessary cases
257+extractPTermNames :: PTerm -- ^ Where to extract names from
258+ -> [Name] -- ^ Extracted names
259+extractPTermNames (PRef _ n) = [n]
260+extractPTermNames (PInferRef _ n) = [n]
261+extractPTermNames (PPatvar _ n) = [n]
262+extractPTermNames (PLam n p1 p2) = n : concatMap extract [p1, p2]
263+extractPTermNames (PPi _ n p1 p2) = n : concatMap extract [p1, p2]
264+extractPTermNames (PLet n p1 p2 p3) = n : concatMap extract [p1, p2, p3]
265+extractPTermNames (PTyped p1 p2) = concatMap extract [p1, p2]
266+extractPTermNames (PApp _ p pas) = let names = concatMap extractPArg pas
267+ in (extract p) ++ names
268+extractPTermNames (PAppBind _ p pas) = let names = concatMap extractPArg pas
269+ in (extract p) ++ names
270+extractPTermNames (PMatchApp _ n) = [n]
271+extractPTermNames (PCase _ p ps) = let (ps1, ps2) = unzip ps
272+ in concatMap extract (p:(ps1 ++ ps2))
273+extractPTermNames (PRefl _ p) = extract p
274+extractPTermNames (PEq _ p1 p2) = concatMap extract [p1, p2]
275+extractPTermNames (PRewrite _ a b m) | Just c <- m =
276+ concatMap extract [a, b, c]
277+extractPTermNames (PRewrite _ a b _) = concatMap extract [a, b]
278+extractPTermNames (PPair _ _ p1 p2) = concatMap extract [p1, p2]
279+extractPTermNames (PDPair _ _ a b c) = concatMap extract [a, b, c]
280+extractPTermNames (PAlternative _ l) = concatMap extract l
281+extractPTermNames (PHidden p) = extract p
282+extractPTermNames (PGoal _ p1 n p2) = n : concatMap extract [p1, p2]
283+extractPTermNames (PDoBlock pdos) = concatMap extractPDo pdos
284+extractPTermNames (PIdiom _ p) = extract p
285+extractPTermNames (PMetavar n) = [n]
286+extractPTermNames (PProof tacts) = concatMap extractPTactic tacts
287+extractPTermNames (PTactics tacts) = concatMap extractPTactic tacts
288+extractPTermNames (PCoerced p) = extract p
289+extractPTermNames (PDisamb _ p) = extract p
290+extractPTermNames (PUnifyLog p) = extract p
291+extractPTermNames (PNoImplicits p) = extract p
292+extractPTermNames _ = []
293+
294+extract = extractPTermNames
295+
296+extractPArg (PImp {pname=n, getTm=p}) = n : extract p
297+extractPArg (PExp {getTm=p}) = extract p
298+extractPArg (PConstraint {getTm=p}) = extract p
299+extractPArg (PTacImplicit {pname=n, getScript=p1, getTm=p2})
300+ = n : (concatMap extract [p1, p2])
301+
302+extractPDo (DoExp _ p) = extract p
303+extractPDo (DoBind _ n p) = n : extract p
304+extractPDo (DoBindP _ p1 p2 ps) = let (ps1, ps2) = unzip ps
305+ ps' = ps1 ++ ps2
306+ in concatMap extract (p1 : p2 : ps')
307+extractPDo (DoLet _ n p1 p2) = n : concatMap extract [p1, p2]
308+extractPDo (DoLetP _ p1 p2) = concatMap extract [p1, p2]
309+
310+extractPTactic (Intro ns) = ns
311+extractPTactic (Focus n) = [n]
312+extractPTactic (Refine n _) = [n]
313+extractPTactic (Rewrite p) = extract p
314+extractPTactic (Induction n) = [n]
315+extractPTactic (Equiv p) = extract p
316+extractPTactic (MatchRefine n) = [n]
317+extractPTactic (LetTac n p) = n : extract p
318+extractPTactic (LetTacTy n p1 p2) = n : concatMap extract [p1, p2]
319+extractPTactic (Exact p) = extract p
320+extractPTactic (ProofSearch _ m ns) | Just n <- m = n : ns
321+extractPTactic (ProofSearch _ _ ns) = ns
322+extractPTactic (Try t1 t2) = concatMap extractPTactic [t1, t2]
323+extractPTactic (TSeq t1 t2) = concatMap extractPTactic [t1, t2]
324+extractPTactic (ApplyTactic p) = extract p
325+extractPTactic (ByReflection p) = extract p
326+extractPTactic (Reflect p) = extract p
327+extractPTactic (Fill p) = extract p
328+extractPTactic (GoalType _ t) = extractPTactic t
329+extractPTactic (TCheck p) = extract p
330+extractPTactic (TEval p) = extract p
331+extractPTactic _ = []
332+
333+-- ------------------------------------------------------- [ HTML Generation ]
334+
335+-- | Generates the actual HTML output based on info from a NsDict
336+-- A merge of the new docs and any existing docs located in the output dir
337+-- is attempted.
338+-- TODO: Ensure the merge always succeeds.
339+-- Currently the content of 'docs/<builtins>.html' may change between
340+-- runs, thus not always containing all items referred from other
341+-- namespace .html files.
342+createDocs :: IState -- ^ Needed to determine the types of names
343+ -> NsDict -- ^ All info from which to generate docs
344+ -> FilePath -- ^ The base directory to which
345+ -- documentation will be written.
346+ -> IO (Failable ())
347+createDocs ist nsd out =
348+ do docInfo <- readDocInfo out
349+ let (new, docInfo') = case docInfo of Nothing -> (True, DocInfo S.empty)
350+ Just di -> (False, di)
351+ nss = S.union (M.keysSet nsd) (namespaces docInfo')
352+ dExists <- doesDirectoryExist out
353+ if new && dExists then err $ "Output directory (" ++ out ++ ") is" ++
354+ " already in use for other than IdrisDoc."
355+ else do
356+ createDirectoryIfMissing True out
357+ foldl docGen (return ()) (M.toList nsd)
358+ createIndex nss out
359+ writeDocInfo out (docInfo' { namespaces = nss })
360+ copyDependencies out
361+ return $ Right ()
362+
363+ where docGen io (n, c) = do io; createNsDoc ist n c out
364+
365+
366+-- | (Over)writes the 'index.html' file in the given directory with
367+-- an (updated) index of namespaces in the documentation
368+createIndex :: S.Set NsName -- ^ Set of namespace names to
369+ -- include in the index
370+ -> FilePath -- ^ The base directory to which
371+ -- documentation will be written.
372+ -> IO ()
373+createIndex nss out =
374+ do (path, h) <- openTempFile out "index.html"
375+ BS2.hPut h $ renderHtml $ wrapper Nothing $ do
376+ H.h1 $ "Namespaces"
377+ H.ul ! class_ "names" $ do
378+ let path ns = "docs" </> genRelNsPath ns "html"
379+ item ns = do let n = toHtml $ nsName2Str ns
380+ link = toValue $ path ns
381+ H.li $ H.a ! href link ! class_ "code" $ n
382+ sort = L.sortBy (\n1 n2 -> reverse n1 `compare` reverse n2)
383+ forM_ (sort $ S.toList nss) item
384+ hClose h
385+ renameFile path (out </> "index.html")
386+
387+
388+-- | Generates a HTML file for a namespace and its contents.
389+-- The location for e.g. Prelude.Algebra is <base>/Prelude/Algebra.html
390+createNsDoc :: IState -- ^ Needed to determine the types of names
391+ -> NsName -- ^ The name of the namespace to
392+ -- create documentation for
393+ -> NsInfo -- ^ The contents of the namespace
394+ -> FilePath -- ^ The base directory to which
395+ -- documentation will be written.
396+ -> IO ()
397+createNsDoc ist ns content out =
398+ do let tpath = out </> "docs" </> (genRelNsPath ns "html")
399+ dir = takeDirectory tpath
400+ file = takeFileName tpath
401+ visible (_, _, Hidden) = False
402+ visible _ = True
403+ haveDocs (_, Just d, _) = [d]
404+ haveDocs _ = []
405+ -- Do not document private members
406+ content' = filter visible content
407+ -- We cannot do anything without a Doc
408+ content'' = concatMap haveDocs content'
409+ createDirectoryIfMissing True dir
410+ (path, h) <- openTempFile dir file
411+ BS2.hPut h $ renderHtml $ wrapper (Just ns) $ do
412+ H.h1 $ toHtml (nsName2Str ns)
413+ H.dl ! class_ "decls" $ forM_ content'' (createOtherDoc ist)
414+ hClose h
415+ renameFile path tpath
416+
417+
418+-- | Generates a relative filepath for a namespace, appending an extension
419+genRelNsPath :: NsName -- ^ Namespace to generate a path for
420+ -> String -- ^ Extension suffix
421+ -> FilePath
422+genRelNsPath ns suffix = nsName2Str ns <.> suffix
423+
424+
425+-- | Generates a HTML type signature with proper tags
426+-- TODO: Turn docstrings into title attributes more robustly
427+genTypeHeader :: IState -- ^ Needed to determine the types of names
428+ -> FunDoc -- ^ Type to generate type declaration for
429+ -> H.Html -- ^ Resulting HTML
430+genTypeHeader ist (FD n _ args ftype _) = do
431+ H.span ! class_ (toValue $ "name " ++ getType n)
432+ ! title (toValue $ show n)
433+ $ toHtml $ name $ nsroot n
434+ H.span ! class_ "word" $ do nbsp; ":"; nbsp
435+ H.span ! class_ "signature" $ preEscapedToHtml htmlSignature
436+
437+ where
438+ htmlSignature = displayDecorated decorator $ renderCompact signature
439+ signature = pprintPTerm False [] names ftype
440+ names = [ n | (n@(UN n'), _, _, _) <- args,
441+ not (T.isPrefixOf (txt "__") n') ]
442+
443+ decorator AnnConstData str = htmlSpan str "data" str
444+ decorator AnnConstType str = htmlSpan str "type" str
445+ decorator AnnKeyword str = htmlSpan "" "keyword" str
446+ decorator (AnnBoundName n i) str | Just t <- M.lookup n docs =
447+ let cs = (if i then "implicit " else "") ++ "documented boundvar"
448+ in htmlSpan t cs str
449+ decorator (AnnBoundName _ i) str =
450+ let cs = (if i then "implicit " else "") ++ "boundvar"
451+ in htmlSpan "" cs str
452+ decorator (AnnName n _ _ _) str
453+ | filterName n = htmlLink (show n) (getType n) (link n) str
454+ | otherwise = htmlSpan "" (getType n) str
455+ decorator (AnnTextFmt BoldText) str = "<b>" ++ str ++ "</b>"
456+ decorator (AnnTextFmt UnderlineText) str = "<u>" ++ str ++ "</u>"
457+ decorator (AnnTextFmt ItalicText) str = "<i>" ++ str ++ "</i>"
458+ decorator _ str = str
459+
460+ htmlSpan :: String -> String -> String -> String
461+ htmlSpan t cs str = do
462+ R.renderHtml $ H.span ! class_ (toValue cs)
463+ ! title (toValue t)
464+ $ toHtml str
465+ htmlLink :: String -> String -> String -> String -> String
466+ htmlLink t cs a str = do
467+ R.renderHtml $ H.a ! class_ (toValue cs)
468+ ! title (toValue t) ! href (toValue a)
469+ $ toHtml str
470+
471+ docs = M.fromList $ mapMaybe docExtractor args
472+ docExtractor (_, _, _, Nothing) = Nothing
473+ docExtractor (n, _, _, Just d) = Just (n, doc2Str d)
474+ -- TODO: Remove <p> tags more robustly
475+ doc2Str d = let dirty = renderMarkup $ contents $ renderDoc $ d
476+ in take (length dirty - 8) $ drop 3 dirty
477+
478+ name (NS n ns) = show (NS (sUN $ name n) ns)
479+ name n = let n' = show n
480+ in if (head n') `elem` opChars
481+ then '(':(n' ++ ")")
482+ else n'
483+
484+ link n = let path = genRelNsPath (getNs n) "html"
485+ in path ++ "#" ++ (show n)
486+
487+ getType :: Name -> String
488+ getType n = let ctxt = tt_ctxt ist
489+ in case () of
490+ _ | isDConName n ctxt -> "constructor"
491+ _ | isFnName n ctxt -> "function"
492+ _ | isTConName n ctxt -> "type"
493+ _ | otherwise -> ""
494+
495+-- | Generates HTML documentation for a function.
496+createFunDoc :: IState -- ^ Needed to determine the types of names
497+ -> FunDoc -- ^ Function to generate block for
498+ -> H.Html -- ^ Resulting HTML
499+createFunDoc ist fd@(FD name docstring args ftype fixity) = do
500+ H.dt ! (A.id $ toValue $ show name) $ genTypeHeader ist fd
501+ H.dd $ do
502+ (if nullDocstring docstring then Empty else renderDoc docstring)
503+ let args' = filter (\(_, _, _, d) -> isJust d) args
504+ if (not $ null args') || (isJust fixity)
505+ then H.dl $ do
506+ if (isJust fixity) then do
507+ H.dt ! class_ "fixity" $ "Fixity"
508+ let f = fromJust fixity
509+ H.dd ! class_ "fixity" ! title (toValue $ show f) $ genFix f
510+ else Empty
511+ forM_ args' genArg
512+ else Empty
513+
514+ where genFix (Infixl {prec=p}) =
515+ toHtml $ "Left associative, precedence " ++ show p
516+ genFix (Infixr {prec=p}) =
517+ toHtml $ "Left associative, precedence " ++ show p
518+ genFix (InfixN {prec=p}) =
519+ toHtml $ "Non-associative, precedence " ++ show p
520+ genFix (PrefixN {prec=p}) =
521+ toHtml $ "Prefix, precedence " ++ show p
522+ genArg (_, _, _, Nothing) = Empty
523+ genArg (name, _, _, Just docstring) = do
524+ H.dt $ toHtml $ show name
525+ H.dd $ renderDoc docstring
526+
527+
528+-- | Generates HTML documentation for any Docs type
529+-- TODO: Generate actual signatures for typeclasses
530+createOtherDoc :: IState -- ^ Needed to determine the types of names
531+ -> Docs -- ^ Namespace item to generate HTML block for
532+ -> H.Html -- ^ Resulting HTML
533+createOtherDoc ist (FunDoc fd) = createFunDoc ist fd
534+
535+createOtherDoc ist (ClassDoc n docstring fds) = do
536+ H.dt ! (A.id $ toValue $ show n) $ do
537+ H.span ! class_ "word" $ do "class"; nbsp
538+ H.span ! class_ "name type"
539+ ! title (toValue $ show n)
540+ $ toHtml $ name $ nsroot n
541+ H.span ! class_ "signature" $ nbsp
542+ H.dd $ do
543+ (if nullDocstring docstring then Empty else renderDoc docstring)
544+ H.dl ! class_ "decls" $ forM_ fds (createFunDoc ist)
545+
546+ where name (NS n ns) = show (NS (sUN $ name n) ns)
547+ name n = let n' = show n
548+ in if (head n') `elem` opChars
549+ then '(':(n' ++ ")")
550+ else n'
551+
552+createOtherDoc ist (DataDoc fd@(FD n docstring args _ _) fds) = do
553+ H.dt ! (A.id $ toValue $ show n) $ do
554+ H.span ! class_ "word" $ do "data"; nbsp
555+ genTypeHeader ist fd
556+ H.dd $ do
557+ (if nullDocstring docstring then Empty else renderDoc docstring)
558+ let args' = filter (\(_, _, _, d) -> isJust d) args
559+ if not $ null args'
560+ then H.dl $ forM_ args' genArg
561+ else Empty
562+ H.dl ! class_ "decls" $ forM_ fds (createFunDoc ist)
563+
564+ where genArg (_, _, _, Nothing) = Empty
565+ genArg (name, _, _, Just docstring) = do
566+ H.dt $ toHtml $ show name
567+ H.dd $ renderDoc docstring
568+
569+
570+-- | Generates everything but the actual content of the page
571+wrapper :: Maybe NsName -- ^ Namespace name, unless it is the index
572+ -> H.Html -- ^ Inner HTML
573+ -> H.Html
574+wrapper ns inner =
575+ let (index, str) = extract ns
576+ base = if index then "" else "../"
577+ styles = base ++ "styles.css" :: String
578+ indexPage = base ++ "index.html" :: String
579+ in H.docTypeHtml $ do
580+ H.head $ do
581+ H.title $ do
582+ "IdrisDoc"
583+ if index then " Index" else do
584+ ": "
585+ toHtml str
586+ H.link ! type_ "text/css" ! rel "stylesheet"
587+ ! href (toValue styles)
588+ H.body ! class_ (if index then "index" else "namespace") $ do
589+ H.div ! class_ "wrapper" $ do
590+ H.header $ do
591+ H.strong "IdrisDoc"
592+ if index then Empty else do
593+ ": "
594+ toHtml str
595+ H.nav $ H.a ! href (toValue indexPage) $ "Index"
596+ H.div ! class_ "container" $ inner
597+ H.footer $ do
598+ "Produced by IdrisDoc version "
599+ toHtml version
600+
601+ where extract (Just ns) = (False, nsName2Str ns)
602+ extract _ = (True, "")
603+
604+
605+-- | Non-break space character
606+nbsp :: H.Html
607+nbsp = preEscapedToHtml (" " :: String)
608+
609+
610+-- | Copies IdrisDoc dependencies such as stylesheets to a directory
611+copyDependencies :: FilePath
612+ -> IO ()
613+copyDependencies dir =
614+ do styles <- getDataFileName $ "idrisdoc" </> "styles.css"
615+ copyFile styles (dir </> "styles.css")
616+
617+-- ---------------------------------------------------- [ DocInfo Read/Write ]
618+
619+-- | Name of the DocInfo file
620+docInfoFile :: String
621+docInfoFile = "IdrisDoc"
622+
623+
624+-- | Reads the 'IdrisDoc' file from the given directory, if it is there
625+-- The info within is converted to a DocInfo
626+readDocInfo :: FilePath -- ^ The IdrisDoc directory also containing the info
627+ -> IO (Maybe DocInfo)
628+readDocInfo dir =
629+ do exists <- doesFileExist (dir </> docInfoFile)
630+ if not exists
631+ then return Nothing
632+ -- Filter out namespaces for which documentation no longer exists
633+ else do di <- (withFile (dir </> docInfoFile) ReadMode reader)
634+ s <- S.fold (onlyValid dir) (return S.empty) (namespaces di)
635+ return . Just . DocInfo $ s
636+
637+ where reader h = let converter = text2DocInfo . E.decodeUtf8
638+ in converter `fmap` BS.hGetContents h
639+ onlyValid out ns s = do s' <- s
640+ let end = (genRelNsPath ns "html")
641+ exists <- doesFileExist $ out </> end
642+ if exists then return $ S.insert ns s'
643+ else s
644+
645+-- | Writes a DocInfo to the 'IdrisDoc' file in the given directory
646+writeDocInfo :: FilePath -- ^ The directory to write to
647+ -> DocInfo -- ^ The DocInfo to write
648+ -> IO ()
649+writeDocInfo dir info = withFile (dir </> docInfoFile) WriteMode writer
650+
651+ where writer h = BS.hPut h $ E.encodeUtf8 $ docInfo2Text info
652+
653+
654+-- | Converts a DocInfo to Text for easy writing
655+docInfo2Text :: DocInfo
656+ -> T.Text
657+docInfo2Text (DocInfo {namespaces=nss}) = S.fold folder T.empty nss
658+
659+ where folder [] res = T.append (txt rootNsStr) (T.cons '\n' res)
660+ folder ns res = let base = (T.append (head ns) $ T.cons '\n' res)
661+ in foldr joiner base (tail ns)
662+ joiner n r = T.append n (T.cons '.' r)
663+
664+
665+-- | Converts an unmodified Text created by 'docInfo2Text' to DocInfo
666+text2DocInfo :: T.Text
667+ -> DocInfo
668+text2DocInfo text = DocInfo $ foldl nsAdder S.empty (T.lines text)
669+
670+ where nsAdder set text = S.insert (txt2Ns text) set
671+ txt2Ns t | t == (txt rootNsStr) = []
672+ txt2Ns t = reverse $ T.splitOn (T.singleton '.') t