@@ -1,22 +1,27 @@
11{-# LANGUAGE PatternGuards #-}
2+{-# LANGUAGE OverloadedStrings #-}
23
34-- | Generation of HTML documentation for Idris code
45module Idris.IdrisDoc (generateDocs) where
56
6−import Idris.Core.TT (Name (..), txt, str, nsroot)
7+import Idris.Core.TT (Name (..), SpecialName (..), txt, str, nsroot)
78import Idris.Core.Evaluate (ctxtAlist, Def (..), lookupDefAcc,
89 Accessibility (..))
910import Idris.AbsSyntax
1011import Idris.Docs
1112
13+import Paths_idris (getDataFileName)
14+
15+import Control.Monad (forM_)
1216import Control.Monad.Trans.Error
1317import Control.Monad.Trans.State.Strict
1418
1519import qualified Data.ByteString as BS
20+import qualified Data.ByteString.Lazy as BS2
1621import qualified Data.Text.Encoding as E
1722import qualified Data.List as L
1823import qualified Data.List.Split as LS
19−import qualified Data.Map as M
24+import qualified Data.Map as M hiding ((!))
2025import qualified Data.Set as S
2126import qualified Data.Text as T
2227
@@ -25,6 +30,12 @@ import System.IO.Error
2530import System.FilePath
2631import System.Directory
2732
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)
38+
2839-- ---------------------------------------------------------------- [ Public ]
2940
3041-- | Generates HTML documentation for a series of loaded namespaces and their dependencies.
@@ -69,6 +80,9 @@ data DocInfo = DocInfo {
6980err :: String -> IO (Failable ())
7081err s = return $ Left s
7182
83+-- | IdrisDoc version
84+version :: String
85+version = "1.0"
7286
7387-- | Converts a Name into a [Text] corresponding to the namespace
7488-- part of a NS Name.
@@ -109,8 +123,31 @@ fetchInfo :: IState -- ^ IState to fetch info from
109123fetchInfo ist nss =
110124 do let originNss = S.fromList nss
111125 info <- nsDict ist
112− let reachedNss = traceNss info originNss S.empty
113− return $ M.filterWithKey (\k _ -> S.member k reachedNss) info
126+ let info' = M.map (filter (filterName . (\(n, _, _) -> n))) info
127+ info'' = M.map removeOrphans info'
128+ reachedNss = traceNss info'' originNss S.empty
129+ return $ M.filterWithKey (\k _ -> S.member k reachedNss) info''
130+
131+
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
136+removeOrphans list =
137+ let children = S.fromList $ concatMap (names . (\(_, d, _) -> d)) list
138+ in filter ((`S.notMember` children) . (\(n, _, _) -> n)) list
139+
140+ where names (Just (DataDoc _ fds)) = map (\(FD n _ _ _ _) -> n) fds
141+ names (Just (ClassDoc _ _ fds)) = map (\(FD n _ _ _ _) -> n) fds
142+ names _ = []
143+
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
150+filterName _ = False
114151
115152
116153-- | Finds all namespaces indirectly referred by a set of namespaces.
@@ -303,6 +340,7 @@ createDocs nsd out =
303340-- else putStrLn "Updating IdrisDoc index"
304341 createIndex nss out
305342 writeDocInfo out (docInfo' { namespaces = nss })
343+ copyDependencies out
306344 return $ Right ()
307345
308346 where docGen out io (n, c) =
@@ -320,7 +358,14 @@ createIndex :: S.Set NsName -- ^ Set of namespace names to
320358 -> IO ()
321359createIndex nss out =
322360 do (path, h) <- openTempFile out "index.html"
323− hPutStr h $ show $ nss -- TODO: Generate HTML instead
361+ BS2.hPut h $ renderHtml $ wrapper Nothing $ do
362+ H.h1 $ "Namespaces"
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
324369 hClose h
325370 renameFile path (out </> "index.html")
326371
@@ -334,12 +379,22 @@ createNsDoc :: NsName -- ^ The name of the namespace to
334379 -- documentation will be written.
335380 -> IO ()
336381createNsDoc ns content out =
337− do let tpath = out </> (genRelNsPath ns "ns.html")
338− dir = takeDirectory tpath
339− file = takeFileName tpath
382+ do let tpath = out </> (genRelNsPath ns "ns.html")
383+ dir = takeDirectory tpath
384+ file = takeFileName tpath
385+ nonHidden (_, _, Hidden) = False
386+ nonHidden _ = True
387+ haveDocs (_, Nothing, _) = False
388+ haveDocs _ = True
389+ -- Do not document private members
390+ content' = filter nonHidden content
391+ -- We cannot do anything without a Doc
392+ content'' = filter haveDocs content'
340393 createDirectoryIfMissing True dir
341394 (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)
343398 hClose h
344399 renameFile path tpath
345400
@@ -352,6 +407,51 @@ genRelNsPath ns suffix = subpath ns <.> suffix
352407
353408 where subpath = L.foldl1' (</>) . LS.splitOn "." . nsName2Str
354409
410+
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
414+ -> H.Html
415+wrapper ns inner =
416+ let (index, str, nestings) = extract ns
417+ base = if nestings > 0
418+ then foldl1 (</>) (replicate nestings "..")
419+ else "."
420+ in H.docTypeHtml $ do
421+ H.head $ do
422+ H.title $ do
423+ "IdrisDoc"
424+ if index then " Index" else do
425+ ": "
426+ toHtml str
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
431+ H.header $ do
432+ H.strong "IdrisDoc"
433+ if index then "" else do
434+ ": "
435+ toHtml str
436+ H.nav $ H.a ! href "index.html" $ "Index"
437+ H.div ! class_ "container" $ inner
438+ H.footer $ do
439+ "Produced by IdrisDoc version "
440+ toHtml version
441+
442+
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)
446+
447+
448+-- | Copies IdrisDoc dependencies such as stylesheets to a directory
449+copyDependencies :: FilePath
450+ -> IO ()
451+copyDependencies dir =
452+ do styles <- getDataFileName $ "idrisdoc" </> "styles.css"
453+ copyFile styles (dir </> "styles.css")
454+
355455-- ---------------------------------------------------- [ DocInfo Read/Write ]
356456
357457-- | Name of the DocInfo file