@@ -5,9 +5,10 @@
55module Idris.IdrisDoc (generateDocs) where
66
77import Idris.Core.TT (Name (..), sUN, SpecialName (..), OutputAnnotation (..),
8− txt, str, nsroot)
8+ TextFormatting (..), txt, str, nsroot)
99import Idris.Core.Evaluate (ctxtAlist, Def (..), lookupDefAcc,
10− Accessibility (..))
10+ Accessibility (..), isDConName, isFnName,
11+ isTConName)
1112import Idris.ParseHelpers (opChars)
1213import Idris.AbsSyntax
1314import Idris.Docs
@@ -64,14 +65,15 @@ generateDocs ist nss' out =
6465 docs <- fetchInfo ist nss
6566 let (c, io) = foldl (checker docs) (0, return ()) nss
6667 io
67− if c < length nss then catchIOError (createDocs docs out) (err . show)
68− else err "No namespaces to generate documentation for"
69− where
70− checker docs st ns | M.member ns docs = st
71− checker docs (c, io) ns = (c+1, do prev <- io; warnMissing ns)
72− warnMissing ns =
73− putStrLn $ "Warning: Ignoring empty or non-existing namespace '" ++
74− (nsName2Str ns) ++ "'"
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) ++ "'"
7577
7678-- ----------------------------------------------------------------- [ Types ]
7779
@@ -115,7 +117,7 @@ getNs _ = []
115117
116118-- | String to replace for the root namespace
117119rootNsStr :: String
118−rootNsStr = "<builtins>"
120+rootNsStr = "[builtins]"
119121
120122
121123-- | Converts a NsName to string form
@@ -334,14 +336,15 @@ extractPTactic _ = []
334336-- A merge of the new docs and any existing docs located in the output dir
335337-- is attempted.
336338-- TODO: Ensure the merge always succeeds.
337−-- Currently the content of '<builtins>.ns.html' may change between
339+-- Currently the content of 'docs/<builtins>.html' may change between
338340-- runs, thus not always containing all items referred from other
339−-- .ns.html files.
340−createDocs :: NsDict -- ^ All info from which to generate docs
341+-- namespace .html files.
342+createDocs :: IState -- ^ Needed to determine the types of names
343+ -> NsDict -- ^ All info from which to generate docs
341344 -> FilePath -- ^ The base directory to which
342345 -- documentation will be written.
343346 -> IO (Failable ())
344−createDocs nsd out =
347+createDocs ist nsd out =
345348 do docInfo <- readDocInfo out
346349 let (new, docInfo') = case docInfo of Nothing -> (True, DocInfo S.empty)
347350 Just di -> (False, di)
@@ -357,7 +360,7 @@ createDocs nsd out =
357360 copyDependencies out
358361 return $ Right ()
359362
360− where docGen io (n, c) = do io; createNsDoc nsd n c out
363+ where docGen io (n, c) = do io; createNsDoc ist n c out
361364
362365
363366-- | (Over)writes the 'index.html' file in the given directory with
@@ -372,7 +375,7 @@ createIndex nss out =
372375 BS2.hPut h $ renderHtml $ wrapper Nothing $ do
373376 H.h1 $ "Namespaces"
374377 H.ul ! class_ "names" $ do
375− let path ns = genRelNsPath ns "ns.html"
378+ let path ns = "docs" </> genRelNsPath ns "html"
376379 item ns = do let n = toHtml $ nsName2Str ns
377380 link = toValue $ path ns
378381 H.li $ H.a ! href link ! class_ "code" $ n
@@ -384,30 +387,30 @@ createIndex nss out =
384387
385388-- | Generates a HTML file for a namespace and its contents.
386389-- The location for e.g. Prelude.Algebra is <base>/Prelude/Algebra.html
387−createNsDoc :: NsDict -- ^ Information about other namespaces
390+createNsDoc :: IState -- ^ Needed to determine the types of names
388391 -> NsName -- ^ The name of the namespace to
389392 -- create documentation for
390393 -> NsInfo -- ^ The contents of the namespace
391394 -> FilePath -- ^ The base directory to which
392395 -- documentation will be written.
393396 -> IO ()
394−createNsDoc nsd ns content out =
395− do let tpath = out </> (genRelNsPath ns "ns.html")
396− dir = takeDirectory tpath
397− file = takeFileName tpath
398− nonHidden (_, _, Hidden) = False
399− nonHidden _ = True
400− haveDocs (_, Nothing, _) = []
401− haveDocs (_, Just d, _) = [d]
402− -- Do not document private members
403− content' = filter nonHidden content
404− -- We cannot do anything without a Doc
405− content'' = concatMap haveDocs content'
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'
406409 createDirectoryIfMissing True dir
407410 (path, h) <- openTempFile dir file
408411 BS2.hPut h $ renderHtml $ wrapper (Just ns) $ do
409412 H.h1 $ toHtml (nsName2Str ns)
410− H.dl ! class_ "decls" $ forM_ content'' (createOtherDoc nsd)
413+ H.dl ! class_ "decls" $ forM_ content'' (createOtherDoc ist)
411414 hClose h
412415 renameFile path tpath
413416
@@ -416,20 +419,20 @@ createNsDoc nsd ns content out =
416419genRelNsPath :: NsName -- ^ Namespace to generate a path for
417420 -> String -- ^ Extension suffix
418421 -> FilePath
419−genRelNsPath ns suffix = subpath ns <.> suffix
420−
421− where subpath = L.foldl1' (</>) . LS.splitOn "." . nsName2Str
422+genRelNsPath ns suffix = nsName2Str ns <.> suffix
422423
423424
424425-- | Generates a HTML type signature with proper tags
425426-- TODO: Turn docstrings into title attributes more robustly
426−genTypeHeader :: NsDict -- ^ Information about namespaces
427+genTypeHeader :: IState -- ^ Needed to determine the types of names
427428 -> FunDoc -- ^ Type to generate type declaration for
428429 -> H.Html -- ^ Resulting HTML
429−genTypeHeader nsd (FD n _ args ftype _) = do
430− H.span ! class_ "name" ! title (toValue $ show n) $ toHtml $ name $ nsroot n
431− " : "
432− preEscapedToHtml htmlSignature
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
433436
434437 where
435438 htmlSignature = displayDecorated decorator $ renderCompact signature
@@ -437,25 +440,39 @@ genTypeHeader nsd (FD n _ args ftype _) = do
437440 names = [ n | (n@(UN n'), _, _, _) <- args,
438441 not (T.isPrefixOf (txt "__") n') ]
439442
440− decorator (AnnName n _ _ _) str | str /= show (nsroot n) = str
441− decorator (AnnName n _ _ _) str | filterName n, isFun n = do
442− R.renderHtml $ H.a ! class_ "name"
443− ! title (toValue $ show n) ! href (toValue $ link n)
444− $ toHtml $ str
445− decorator (AnnName n _ _ _) str | filterName n = do
446− R.renderHtml $ H.a ! class_ "type"
447− ! title (toValue $ show n) ! href (toValue $ link n)
448− $ toHtml $ str
449− decorator (AnnBoundName n _) str | Just t <- M.lookup n docs = do
450− R.renderHtml $ H.span ! class_ "arg" ! title (toValue t)
451− $ toHtml $ str
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>"
452458 decorator _ str = str
453459
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+
454471 docs = M.fromList $ mapMaybe docExtractor args
455472 docExtractor (_, _, _, Nothing) = Nothing
456− docExtractor (n, _, _, Just d) = Just (n, doc2Txt d)
473+ docExtractor (n, _, _, Just d) = Just (n, doc2Str d)
457474 -- TODO: Remove <p> tags more robustly
458− doc2Txt d = let dirty = renderMarkup $ contents $ renderDoc $ d
475+ doc2Str d = let dirty = renderMarkup $ contents $ renderDoc $ d
459476 in take (length dirty - 8) $ drop 3 dirty
460477
461478 name (NS n ns) = show (NS (sUN $ name n) ns)
@@ -464,23 +481,23 @@ genTypeHeader nsd (FD n _ args ftype _) = do
464481 then '(':(n' ++ ")")
465482 else n'
466483
467− link n = let path = genRelNsPath (getNs n) "ns.html"
484+ link n = let path = genRelNsPath (getNs n) "html"
468485 in path ++ "#" ++ (show n)
469486
470− isFun n =
471− let ns = getNs n
472− in case M.lookup ns nsd of
473− Nothing -> False -- Should never happen
474− Just nsi -> case L.find (\(n', d, a) -> n == n') nsi of
475− Just (_, Just (FunDoc _), _) -> True
476− _ -> False
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 -> ""
477494
478495-- | Generates HTML documentation for a function.
479−createFunDoc :: NsDict -- ^ Information about other namespaces
496+createFunDoc :: IState -- ^ Needed to determine the types of names
480497 -> FunDoc -- ^ Function to generate block for
481498 -> H.Html -- ^ Resulting HTML
482−createFunDoc nsd fd@(FD name docstring args ftype fixity) = do
483− H.dt ! (A.id $ toValue $ show name) $ genTypeHeader nsd fd
499+createFunDoc ist fd@(FD name docstring args ftype fixity) = do
500+ H.dt ! (A.id $ toValue $ show name) $ genTypeHeader ist fd
484501 H.dd $ do
485502 (if nullDocstring docstring then Empty else renderDoc docstring)
486503 let args' = filter (\(_, _, _, d) -> isJust d) args
@@ -510,30 +527,39 @@ createFunDoc nsd fd@(FD name docstring args ftype fixity) = do
510527
511528-- | Generates HTML documentation for any Docs type
512529-- TODO: Generate actual signatures for typeclasses
513−createOtherDoc :: NsDict -- ^ Information about other namespaces
530+createOtherDoc :: IState -- ^ Needed to determine the types of names
514531 -> Docs -- ^ Namespace item to generate HTML block for
515532 -> H.Html -- ^ Resulting HTML
516−createOtherDoc nsd (FunDoc fd) = createFunDoc nsd fd
533+createOtherDoc ist (FunDoc fd) = createFunDoc ist fd
517534
518−createOtherDoc nsd (ClassDoc n docstring fds) = do
535+createOtherDoc ist (ClassDoc n docstring fds) = do
519536 H.dt ! (A.id $ toValue $ show n) $ do
520− "class "
521− toHtml $ show n
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
522542 H.dd $ do
523543 (if nullDocstring docstring then Empty else renderDoc docstring)
524− H.dl ! class_ "decls" $ forM_ fds (createFunDoc nsd)
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'
525551
526−createOtherDoc nsd (DataDoc fd@(FD n docstring args _ _) fds) = do
552+createOtherDoc ist (DataDoc fd@(FD n docstring args _ _) fds) = do
527553 H.dt ! (A.id $ toValue $ show n) $ do
528− "data "
529− genTypeHeader nsd fd
554+ H.span ! class_ "word" $ do "data"; nbsp
555+ genTypeHeader ist fd
530556 H.dd $ do
531557 (if nullDocstring docstring then Empty else renderDoc docstring)
532558 let args' = filter (\(_, _, _, d) -> isJust d) args
533559 if not $ null args'
534560 then H.dl $ forM_ args' genArg
535561 else Empty
536− H.dl ! class_ "decls" $ forM_ fds (createFunDoc nsd)
562+ H.dl ! class_ "decls" $ forM_ fds (createFunDoc ist)
537563
538564 where genArg (_, _, _, Nothing) = Empty
539565 genArg (name, _, _, Just docstring) = do
@@ -546,10 +572,10 @@ wrapper :: Maybe NsName -- ^ Namespace name, unless it is the index
546572 -> H.Html -- ^ Inner HTML
547573 -> H.Html
548574wrapper ns inner =
549− let (index, str, nestings) = extract ns
550− base = if nestings > 0
551− then foldl1 (</>) (replicate nestings "..")
552− else "."
575+ let (index, str) = extract ns
576+ base = if index then "" else "../"
577+ styles = base ++ "styles.css" :: String
578+ indexPage = base ++ "index.html" :: String
553579 in H.docTypeHtml $ do
554580 H.head $ do
555581 H.title $ do
@@ -557,8 +583,8 @@ wrapper ns inner =
557583 if index then " Index" else do
558584 ": "
559585 toHtml str
560− H.base ! href (toValue base)
561− H.link ! type_ "text/css" ! rel "stylesheet" ! href "styles.css"
586+ H.link ! type_ "text/css" ! rel "stylesheet"
587+ ! href (toValue styles)
562588 H.body ! class_ (if index then "index" else "namespace") $ do
563589 H.div ! class_ "wrapper" $ do
564590 H.header $ do
@@ -566,15 +592,19 @@ wrapper ns inner =
566592 if index then Empty else do
567593 ": "
568594 toHtml str
569− H.nav $ H.a ! href "index.html" $ "Index"
595+ H.nav $ H.a ! href (toValue indexPage) $ "Index"
570596 H.div ! class_ "container" $ inner
571597 H.footer $ do
572598 "Produced by IdrisDoc version "
573599 toHtml version
574600
575− where extract (Just ns) = let nestings = if null ns then 1 else length ns
576− in (False, nsName2Str ns, nestings-1)
577− extract _ = (True, "", 0)
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)
578608
579609
580610-- | Copies IdrisDoc dependencies such as stylesheets to a directory
@@ -607,7 +637,7 @@ readDocInfo dir =
607637 where reader h = let converter = text2DocInfo . E.decodeUtf8
608638 in converter `fmap` BS.hGetContents h
609639 onlyValid out ns s = do s' <- s
610− let end = (genRelNsPath ns "ns.html")
640+ let end = (genRelNsPath ns "html")
611641 exists <- doesFileExist $ out </> end
612642 if exists then return $ S.insert ns s'
613643 else s