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