@@ -1,22 +1,27 @@
1{-# LANGUAGE PatternGuards #-}
1{-# LANGUAGE PatternGuards #-}
2+{-# LANGUAGE OverloadedStrings #-}
3-- | Generation of HTML documentation for Idris code
4-- | Generation of HTML documentation for Idris code
4module Idris.IdrisDoc (generateDocs) where
5module Idris.IdrisDoc (generateDocs) where
6−import Idris.Core.TT (Name (..), txt, str, nsroot)
7+import Idris.Core.TT (Name (..), SpecialName (..), txt, str, nsroot)
7import Idris.Core.Evaluate (ctxtAlist, Def (..), lookupDefAcc,
8import Idris.Core.Evaluate (ctxtAlist, Def (..), lookupDefAcc,
8 Accessibility (..))
9 Accessibility (..))
9import Idris.AbsSyntax
10import Idris.AbsSyntax
10import Idris.Docs
11import Idris.Docs
13+import Paths_idris (getDataFileName)
15+import Control.Monad (forM_)
12import Control.Monad.Trans.Error
16import Control.Monad.Trans.Error
13import Control.Monad.Trans.State.Strict
17import Control.Monad.Trans.State.Strict
15import qualified Data.ByteString as BS
19import qualified Data.ByteString as BS
20+import qualified Data.ByteString.Lazy as BS2
16import qualified Data.Text.Encoding as E
21import qualified Data.Text.Encoding as E
17import qualified Data.List as L
22import qualified Data.List as L
18import qualified Data.List.Split as LS
23import qualified Data.List.Split as LS
19−import qualified Data.Map as M
24+import qualified Data.Map as M hiding ((!))
20import qualified Data.Set as S
25import qualified Data.Set as S
21import qualified Data.Text as T
26import qualified Data.Text as T
@@ -25,6 +30,12 @@ import System.IO.Error
25import System.FilePath
30import System.FilePath
26import System.Directory
31import System.Directory
33+import Text.Blaze (toValue)
34+import Text.Blaze.Html5 ((!), toHtml)
35+import qualified Text.Blaze.Html5 as H
36+import Text.Blaze.Html5.Attributes
37+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
28-- ---------------------------------------------------------------- [ Public ]
39-- ---------------------------------------------------------------- [ Public ]
30-- | Generates HTML documentation for a series of loaded namespaces and their dependencies.
41-- | Generates HTML documentation for a series of loaded namespaces and their dependencies.
@@ -69,6 +80,9 @@ data DocInfo = DocInfo {
69err :: String -> IO (Failable ())
80err :: String -> IO (Failable ())
70err s = return $ Left s
81err s = return $ Left s
73-- | Converts a Name into a [Text] corresponding to the namespace
87-- | Converts a Name into a [Text] corresponding to the namespace
74-- part of a NS Name.
88-- part of a NS Name.
@@ -109,8 +123,31 @@ fetchInfo :: IState -- ^ IState to fetch info from
109fetchInfo ist nss =
123fetchInfo ist nss =
110 do let originNss = S.fromList nss
124 do let originNss = S.fromList nss
111 info <- nsDict ist
125 info <- nsDict ist
126+ let info' = M.map (filter (filterName . (\(n, _, _) -> n))) info
127+ info'' = M.map removeOrphans info'
112− let reachedNss = traceNss info originNss S.empty
128+ reachedNss = traceNss info'' originNss S.empty
113− return $ M.filterWithKey (\k _ -> S.member k reachedNss) info
129+ return $ M.filterWithKey (\k _ -> S.member k reachedNss) info''
132+-- | Removes loose class methods and data constructors,
133+-- leaving them documented only under their parent.
134+removeOrphans :: [NsItem] -- ^ List to remove orphans from
135+ -> [NsItem] -- ^ Orphan-free list
137+ let children = S.fromList $ concatMap (names . (\(_, d, _) -> d)) list
138+ in filter ((`S.notMember` children) . (\(n, _, _) -> n)) list
140+ where names (Just (DataDoc _ fds)) = map (\(FD n _ _ _ _) -> n) fds
141+ names (Just (ClassDoc _ _ fds)) = map (\(FD n _ _ _ _) -> n) fds
144+-- | Whether a Name names something which should be documented
145+filterName :: Name -- ^ Name to check
146+ -> Bool -- ^ Predicate result
147+filterName (UN n) | '@':'@':_ <- str n = False
148+filterName (UN _) = True
149+filterName (NS n _) = filterName n
116-- | Finds all namespaces indirectly referred by a set of namespaces.
153-- | Finds all namespaces indirectly referred by a set of namespaces.
@@ -303,6 +340,7 @@ createDocs nsd out =
303-- else putStrLn "Updating IdrisDoc index"
340-- else putStrLn "Updating IdrisDoc index"
304 createIndex nss out
341 createIndex nss out
305 writeDocInfo out (docInfo' { namespaces = nss })
342 writeDocInfo out (docInfo' { namespaces = nss })
343+ copyDependencies out
306 return $ Right ()
344 return $ Right ()
308 where docGen out io (n, c) =
346 where docGen out io (n, c) =
@@ -320,7 +358,14 @@ createIndex :: S.Set NsName -- ^ Set of namespace names to
321createIndex nss out =
359createIndex nss out =
322 do (path, h) <- openTempFile out "index.html"
360 do (path, h) <- openTempFile out "index.html"
323− hPutStr h $ show $ nss -- TODO: Generate HTML instead
361+ BS2.hPut h $ renderHtml $ wrapper Nothing $ do
363+ 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
325 renameFile path (out </> "index.html")
370 renameFile path (out </> "index.html")
@@ -334,12 +379,22 @@ createNsDoc :: NsName -- ^ The name of the namespace to
334 -- documentation will be written.
379 -- documentation will be written.
336createNsDoc ns content out =
381createNsDoc ns content out =
337− do let tpath = out </> (genRelNsPath ns "ns.html")
382+ do let tpath = out </> (genRelNsPath ns "ns.html")
338− dir = takeDirectory tpath
383+ dir = takeDirectory tpath
339− file = takeFileName tpath
384+ file = takeFileName tpath
385+ nonHidden (_, _, Hidden) = False
387+ haveDocs (_, Nothing, _) = False
389+ -- Do not document private members
390+ content' = filter nonHidden content
391+ -- We cannot do anything without a Doc
392+ content'' = filter haveDocs content'
340 createDirectoryIfMissing True dir
393 createDirectoryIfMissing True dir
341 (path, h) <- openTempFile dir file
394 (path, h) <- openTempFile dir file
342− hPutStr h $ show $ content -- TODO: Generate HTML instead
395+ BS2.hPut h $ renderHtml $ wrapper (Just ns) $ do
396+ H.h1 $ toHtml (nsName2Str ns)
397+ forM_ content'' (\(n,_,_) -> H.p $ toHtml $ show n)
344 renameFile path tpath
399 renameFile path tpath
@@ -352,6 +407,51 @@ genRelNsPath ns suffix = subpath ns <.> suffix
353 where subpath = L.foldl1' (</>) . LS.splitOn "." . nsName2Str
408 where subpath = L.foldl1' (</>) . LS.splitOn "." . nsName2Str
411+-- | Generates everything but the actual content of the page
412+wrapper :: Maybe NsName -- ^ Namespace name, unless it is the index
413+ -> H.Html -- ^ Inner HTML
416+ let (index, str, nestings) = extract ns
417+ base = if nestings > 0
418+ then foldl1 (</>) (replicate nestings "..")
420+ in H.docTypeHtml $ do
424+ if index then " Index" else do
427+ H.base ! href (toValue base)
428+ H.link ! type_ "text/css" ! rel "stylesheet" ! href "styles.css"
429+ H.body ! class_ (if index then "index" else "namespace") $ do
430+ H.div ! class_ "wrapper" $ do
433+ if index then "" else do
436+ H.nav $ H.a ! href "index.html" $ "Index"
437+ H.div ! class_ "container" $ inner
439+ "Produced by IdrisDoc version "
443+ where extract (Just ns) = let nestings = if null ns then 1 else length ns
444+ in (False, nsName2Str ns, nestings-1)
445+ extract _ = (True, "", 0)
448+-- | Copies IdrisDoc dependencies such as stylesheets to a directory
449+copyDependencies :: FilePath
451+copyDependencies dir =
452+ do styles <- getDataFileName $ "idrisdoc" </> "styles.css"
453+ copyFile styles (dir </> "styles.css")
355-- ---------------------------------------------------- [ DocInfo Read/Write ]
455-- ---------------------------------------------------- [ DocInfo Read/Write ]
357-- | Name of the DocInfo file
457-- | Name of the DocInfo file