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