@@ -4,11 +4,14 @@
44-- | Generation of HTML documentation for Idris code
55module Idris.IdrisDoc (generateDocs) where
66
7−import Idris.Core.TT (Name (..), SpecialName (..), txt, str, nsroot)
7+import Idris.Core.TT (Name (..), sUN, SpecialName (..), OutputAnnotation (..),
8+ txt, str, nsroot)
89import Idris.Core.Evaluate (ctxtAlist, Def (..), lookupDefAcc,
910 Accessibility (..))
11+import Idris.ParseHelpers (opChars)
1012import Idris.AbsSyntax
1113import Idris.Docs
14+import Idris.Docstrings (nullDocstring)
1215
1316import Paths_idris (getDataFileName)
1417
@@ -16,12 +19,15 @@ import Control.Monad (forM_)
1619import Control.Monad.Trans.Error
1720import Control.Monad.Trans.State.Strict
1821
22+import Data.Maybe
23+
1924import qualified Data.ByteString as BS
2025import qualified Data.ByteString.Lazy as BS2
2126import qualified Data.Text.Encoding as E
2227import qualified Data.List as L
2328import qualified Data.List.Split as LS
2429import qualified Data.Map as M hiding ((!))
30+import qualified Data.Ord (compare)
2531import qualified Data.Set as S
2632import qualified Data.Text as T
2733
@@ -30,15 +36,22 @@ import System.IO.Error
3036import System.FilePath
3137import System.Directory
3238
33−import Text.Blaze (toValue)
34−import Text.Blaze.Html5 ((!), toHtml)
39+import Cheapskate.Html (renderDoc)
40+import Text.PrettyPrint.Annotated.Leijen (displayDecorated, renderCompact)
41+
42+import Text.Blaze (toValue, contents)
43+import Text.Blaze.Internal (MarkupM (Empty))
44+import Text.Blaze.Html5 ((!), toHtml, preEscapedToHtml)
3545import qualified Text.Blaze.Html5 as H
36−import Text.Blaze.Html5.Attributes
46+import Text.Blaze.Html5.Attributes as A
3747import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
48+import qualified Text.Blaze.Html.Renderer.String as R
49+import Text.Blaze.Renderer.String (renderMarkup)
3850
3951-- ---------------------------------------------------------------- [ Public ]
4052
41−-- | Generates HTML documentation for a series of loaded namespaces and their dependencies.
53+-- | Generates HTML documentation for a series of loaded namespaces
54+-- and their dependencies.
4255generateDocs :: IState -- ^ IState where all necessary information is
4356 -- extracted from.
4457 -> [Name] -- ^ List of namespaces to generate
@@ -130,7 +143,7 @@ fetchInfo ist nss =
130143
131144
132145-- | Removes loose class methods and data constructors,
133−-- leaving them documented only under their parent.
146+-- leaving them documented only under their parent.
134147removeOrphans :: [NsItem] -- ^ List to remove orphans from
135148 -> [NsItem] -- ^ Orphan-free list
136149removeOrphans list =
@@ -214,7 +227,7 @@ hasDoc _ = False
214227
215228
216229-- | Predicate saying whether a Name possibly may have docs defined
217−-- | Without this, getDocs from Idris.Docs may fail a pattern match.
230+-- Without this, getDocs from Idris.Docs may fail a pattern match.
218231mayHaveDocs :: Name -- ^ The Name to test
219232 -> Bool -- ^ The result
220233mayHaveDocs (UN _) = True
@@ -234,8 +247,8 @@ loadDocs ist n
234247
235248
236249-- | Extracts names referred from a type.
237−-- The covering of all PTerms ensures that we avoid unanticipated cases.
238−-- All of them are probably not needed.
250+-- The covering of all PTerms ensures that we avoid unanticipated cases, though
251+-- all of them are not needed. The author just did not know which!
239252-- TODO: Remove unnecessary cases
240253extractPTermNames :: PTerm -- ^ Where to extract names from
241254 -> [Name] -- ^ Extracted names
@@ -319,8 +332,9 @@ extractPTactic _ = []
319332-- A merge of the new docs and any existing docs located in the output dir
320333-- is attempted.
321334-- TODO: Ensure the merge always succeeds.
322−-- Currently the content of '<builtins>.ns.html' may change between runs,
323−-- thus not always containing all items referred from other .ns.html files.
335+-- Currently the content of '<builtins>.ns.html' may change between
336+-- runs, thus not always containing all items referred from other
337+-- .ns.html files.
324338createDocs :: NsDict -- ^ All info from which to generate docs
325339 -> FilePath -- ^ The base directory to which
326340 -- documentation will be written.
@@ -335,18 +349,13 @@ createDocs nsd out =
335349 " already in use for other than IdrisDoc."
336350 else do
337351 createDirectoryIfMissing True out
338− foldl (docGen out) (return ()) (M.toList nsd)
339−-- if new then putStrLn "Creating IdrisDoc index"
340−-- else putStrLn "Updating IdrisDoc index"
352+ foldl docGen (return ()) (M.toList nsd)
341353 createIndex nss out
342354 writeDocInfo out (docInfo' { namespaces = nss })
343355 copyDependencies out
344356 return $ Right ()
345357
346− where docGen out io (n, c) =
347− do io
348−-- putStrLn $ "Creating IdrisDoc for '" ++ (nsName2Str n) ++ "'"
349− createNsDoc n c out
358+ where docGen io (n, c) = do io; createNsDoc nsd n c out
350359
351360
352361-- | (Over)writes the 'index.html' file in the given directory with
@@ -361,40 +370,42 @@ createIndex nss out =
361370 BS2.hPut h $ renderHtml $ wrapper Nothing $ do
362371 H.h1 $ "Namespaces"
363372 H.ul ! class_ "names" $ do
364− let path ns = genRelNsPath ns "ns.html"
365− item ns = do let n = toHtml $ nsName2Str ns
366− link = toValue $ path ns
367− H.li $ H.a ! href link ! class_ "code" $ n
368− forM_ (S.toList nss) item
373+ let path ns = genRelNsPath ns "ns.html"
374+ item ns = do let n = toHtml $ nsName2Str ns
375+ link = toValue $ path ns
376+ H.li $ H.a ! href link ! class_ "code" $ n
377+ sort = L.sortBy (\n1 n2 -> reverse n1 `compare` reverse n2)
378+ forM_ (sort $ S.toList nss) item
369379 hClose h
370380 renameFile path (out </> "index.html")
371381
372382
373383-- | Generates a HTML file for a namespace and its contents.
374384-- The location for e.g. Prelude.Algebra is <base>/Prelude/Algebra.html
375−createNsDoc :: NsName -- ^ The name of the namespace to
385+createNsDoc :: NsDict -- ^ Information about other namespaces
386+ -> NsName -- ^ The name of the namespace to
376387 -- create documentation for
377388 -> NsInfo -- ^ The contents of the namespace
378389 -> FilePath -- ^ The base directory to which
379390 -- documentation will be written.
380391 -> IO ()
381−createNsDoc ns content out =
392+createNsDoc nsd ns content out =
382393 do let tpath = out </> (genRelNsPath ns "ns.html")
383394 dir = takeDirectory tpath
384395 file = takeFileName tpath
385396 nonHidden (_, _, Hidden) = False
386397 nonHidden _ = True
387− haveDocs (_, Nothing, _) = False
388− haveDocs _ = True
398+ haveDocs (_, Nothing, _) = []
399+ haveDocs (_, Just d, _) = [d]
389400 -- Do not document private members
390401 content' = filter nonHidden content
391402 -- We cannot do anything without a Doc
392− content'' = filter haveDocs content'
403+ content'' = concatMap haveDocs content'
393404 createDirectoryIfMissing True dir
394405 (path, h) <- openTempFile dir file
395406 BS2.hPut h $ renderHtml $ wrapper (Just ns) $ do
396407 H.h1 $ toHtml (nsName2Str ns)
397− forM_ content'' (\(n,_,_) -> H.p $ toHtml $ show n)
408+ H.dl ! class_ "decls" $ forM_ content'' (createOtherDoc nsd)
398409 hClose h
399410 renameFile path tpath
400411
@@ -408,6 +419,123 @@ genRelNsPath ns suffix = subpath ns <.> suffix
408419 where subpath = L.foldl1' (</>) . LS.splitOn "." . nsName2Str
409420
410421
422+-- | Generates a HTML type signature with proper tags
423+-- TODO: Turn docstrings into title attributes more robustly
424+genTypeHeader :: NsDict -- ^ Information about namespaces
425+ -> FunDoc -- ^ Type to generate type declaration for
426+ -> H.Html -- ^ Resulting HTML
427+genTypeHeader nsd (FD n _ args ftype _) = do
428+ H.span ! class_ "name" ! title (toValue $ show n) $ toHtml $ name $ nsroot n
429+ " : "
430+ preEscapedToHtml htmlSignature
431+
432+ where
433+ htmlSignature = displayDecorated decorator $ renderCompact signature
434+ signature = pprintPTerm False [] names ftype
435+ names = [ n | (n@(UN n'), _, _, _) <- args,
436+ not (T.isPrefixOf (txt "__") n') ]
437+
438+ decorator (AnnName n _ _ _) str | filterName n, isFun n = do
439+ R.renderHtml $ H.a ! class_ "name"
440+ ! title (toValue $ show n) ! href (toValue $ link n)
441+ $ toHtml $ show $ nsroot n
442+ decorator (AnnName n _ _ _) str | filterName n = do
443+ R.renderHtml $ H.a ! class_ "type"
444+ ! title (toValue $ show n) ! href (toValue $ link n)
445+ $ toHtml $ show $ nsroot n
446+ decorator (AnnBoundName n _) str | Just t <- M.lookup n docs = do
447+ R.renderHtml $ H.span ! class_ "arg" ! title (toValue t)
448+ $ toHtml $ show n
449+ decorator _ str = str
450+
451+ docs = M.fromList $ mapMaybe docExtractor args
452+ docExtractor (_, _, _, Nothing) = Nothing
453+ docExtractor (n, _, _, Just d) = Just (n, doc2Txt d)
454+ -- TODO: Remove <p> tags more robustly
455+ doc2Txt d = let dirty = renderMarkup $ contents $ renderDoc $ d
456+ in take (length dirty - 8) $ drop 3 dirty
457+
458+ name (NS n ns) = show (NS (sUN $ name n) ns)
459+ name n = let n' = show n
460+ in if (head n') `elem` opChars
461+ then '(':(n' ++ ")")
462+ else n'
463+
464+ link n = let path = genRelNsPath (getNs n) "ns.html"
465+ in path ++ "#" ++ (show n)
466+
467+ isFun n =
468+ let ns = getNs n
469+ in case M.lookup ns nsd of
470+ Nothing -> False -- Should never happen
471+ Just nsi -> case L.find (\(n', d, a) -> n == n') nsi of
472+ Just (_, Just (FunDoc _), _) -> True
473+ _ -> False
474+
475+-- | Generates HTML documentation for a function.
476+createFunDoc :: NsDict -- ^ Information about other namespaces
477+ -> FunDoc -- ^ Function to generate block for
478+ -> H.Html -- ^ Resulting HTML
479+createFunDoc nsd fd@(FD name docstring args ftype fixity) = do
480+ H.dt ! (A.id $ toValue $ show name) $ genTypeHeader nsd fd
481+ H.dd $ do
482+ (if nullDocstring docstring then Empty else renderDoc docstring)
483+ let args' = filter (\(_, _, _, d) -> isJust d) args
484+ if (not $ null args') || (isJust fixity)
485+ then H.dl $ do
486+ if (isJust fixity) then do
487+ H.dt ! class_ "fixity" $ "Fixity"
488+ let f = fromJust fixity
489+ H.dd ! class_ "fixity" ! title (toValue $ show f) $ genFix f
490+ else Empty
491+ forM_ args' genArg
492+ else Empty
493+
494+ where genFix (Infixl {prec=p}) =
495+ toHtml $ "Left associative, precedence " ++ show p
496+ genFix (Infixr {prec=p}) =
497+ toHtml $ "Left associative, precedence " ++ show p
498+ genFix (InfixN {prec=p}) =
499+ toHtml $ "Non-associative, precedence " ++ show p
500+ genFix (PrefixN {prec=p}) =
501+ toHtml $ "Prefix, precedence " ++ show p
502+ genArg (_, _, _, Nothing) = Empty
503+ genArg (name, _, _, Just docstring) = do
504+ H.dt $ toHtml $ show name
505+ H.dd $ renderDoc docstring
506+
507+
508+-- | Generates HTML documentation for any Docs type
509+-- TODO: Generate actual signatures for typeclasses
510+createOtherDoc :: NsDict -- ^ Information about other namespaces
511+ -> Docs -- ^ Namespace item to generate HTML block for
512+ -> H.Html -- ^ Resulting HTML
513+createOtherDoc nsd (FunDoc fd) = createFunDoc nsd fd
514+createOtherDoc nsd (ClassDoc n docstring fds) = do
515+ H.dt ! (A.id $ toValue $ show n) $ do
516+ "class "
517+ toHtml $ show n
518+ H.dd $ do
519+ (if nullDocstring docstring then Empty else renderDoc docstring)
520+ H.dl ! class_ "decls" $ forM_ fds (createFunDoc nsd)
521+createOtherDoc nsd (DataDoc fd@(FD n docstring args _ _) fds) = do
522+ H.dt ! (A.id $ toValue $ show n) $ do
523+ "data "
524+ genTypeHeader nsd fd
525+ H.dd $ do
526+ (if nullDocstring docstring then Empty else renderDoc docstring)
527+ let args' = filter (\(_, _, _, d) -> isJust d) args
528+ if not $ null args'
529+ then H.dl $ forM_ args' genArg
530+ else Empty
531+ H.dl ! class_ "decls" $ forM_ fds (createFunDoc nsd)
532+
533+ where genArg (_, _, _, Nothing) = Empty
534+ genArg (name, _, _, Just docstring) = do
535+ H.dt $ toHtml $ show name
536+ H.dd $ renderDoc docstring
537+
538+
411539-- | Generates everything but the actual content of the page
412540wrapper :: Maybe NsName -- ^ Namespace name, unless it is the index
413541 -> H.Html -- ^ Inner HTML
@@ -430,7 +558,7 @@ wrapper ns inner =
430558 H.div ! class_ "wrapper" $ do
431559 H.header $ do
432560 H.strong "IdrisDoc"
433− if index then "" else do
561+ if index then Empty else do
434562 ": "
435563 toHtml str
436564 H.nav $ H.a ! href "index.html" $ "Index"