028301c · Idris-dev · git.iko.soy

5module Idris.IdrisDoc (generateDocs) where

6

7import Idris.Core.TT (Name (..), sUN, SpecialName (..), OutputAnnotation (..),

8− txt, str, nsroot)

8+ TextFormatting (..), txt, str, nsroot)

9import Idris.Core.Evaluate (ctxtAlist, Def (..), lookupDefAcc,

10− Accessibility (..))

10+ Accessibility (..), isDConName, isFnName,

11+ isTConName)

11import Idris.ParseHelpers (opChars)

12import Idris.ParseHelpers (opChars)

12import Idris.AbsSyntax

13import Idris.AbsSyntax

13import Idris.Docs

14import Idris.Docs

64 docs <- fetchInfo ist nss

65 docs <- fetchInfo ist nss

65 let (c, io) = foldl (checker docs) (0, return ()) nss

66 let (c, io) = foldl (checker docs) (0, return ()) nss

66 io

67 io

68+ if c < length nss

67− if c < length nss then catchIOError (createDocs docs out) (err . show)

69+ then catchIOError (createDocs ist docs out) (err . show)

68− else err "No namespaces to generate documentation for"

70+ else err "No namespaces to generate documentation for"

69− where

71+

70− checker docs st ns | M.member ns docs = st

72+ where checker docs st ns | M.member ns docs = st

71− checker docs (c, io) ns = (c+1, do prev <- io; warnMissing ns)

73+ checker docs (c, io) ns = (c+1, do prev <- io; warnMissing ns)

72− warnMissing ns =

74+ warnMissing ns =

73− putStrLn $ "Warning: Ignoring empty or non-existing namespace '" ++

75+ putStrLn $ "Warning: Ignoring empty or non-existing namespace '" ++

74− (nsName2Str ns) ++ "'"

76+ (nsName2Str ns) ++ "'"

75

77

76-- ----------------------------------------------------------------- [ Types ]

78-- ----------------------------------------------------------------- [ Types ]

77

79

115

117

116-- | String to replace for the root namespace

118-- | String to replace for the root namespace

117rootNsStr :: String

119rootNsStr :: String

118−rootNsStr = "<builtins>"

120+rootNsStr = "[builtins]"

119

121

120

122

121-- | Converts a NsName to string form

123-- | Converts a NsName to string form

334-- A merge of the new docs and any existing docs located in the output dir

336-- A merge of the new docs and any existing docs located in the output dir

335-- is attempted.

337-- is attempted.

336-- TODO: Ensure the merge always succeeds.

338-- TODO: Ensure the merge always succeeds.

337−-- Currently the content of '<builtins>.ns.html' may change between

339+-- Currently the content of 'docs/<builtins>.html' may change between

338-- runs, thus not always containing all items referred from other

340-- runs, thus not always containing all items referred from other

339−-- .ns.html files.

341+-- namespace .html files.

342+createDocs :: IState -- ^ Needed to determine the types of names

340−createDocs :: NsDict -- ^ All info from which to generate docs

343+ -> NsDict -- ^ All info from which to generate docs

341 -> FilePath -- ^ The base directory to which

344 -> FilePath -- ^ The base directory to which

342 -- documentation will be written.

345 -- documentation will be written.

343 -> IO (Failable ())

346 -> IO (Failable ())

344−createDocs nsd out =

347+createDocs ist nsd out =

345 do docInfo <- readDocInfo out

348 do docInfo <- readDocInfo out

346 let (new, docInfo') = case docInfo of Nothing -> (True, DocInfo S.empty)

349 let (new, docInfo') = case docInfo of Nothing -> (True, DocInfo S.empty)

347 Just di -> (False, di)

350 Just di -> (False, di)

357 copyDependencies out

360 copyDependencies out

358 return $ Right ()

361 return $ Right ()

359

362

360− where docGen io (n, c) = do io; createNsDoc nsd n c out

363+ where docGen io (n, c) = do io; createNsDoc ist n c out

361

364

362

365

363-- | (Over)writes the 'index.html' file in the given directory with

366-- | (Over)writes the 'index.html' file in the given directory with

372 BS2.hPut h $ renderHtml $ wrapper Nothing $ do

375 BS2.hPut h $ renderHtml $ wrapper Nothing $ do

373 H.h1 $ "Namespaces"

376 H.h1 $ "Namespaces"

374 H.ul ! class_ "names" $ do

377 H.ul ! class_ "names" $ do

375− let path ns = genRelNsPath ns "ns.html"

378+ let path ns = "docs" </> genRelNsPath ns "html"

376 item ns = do let n = toHtml $ nsName2Str ns

379 item ns = do let n = toHtml $ nsName2Str ns

377 link = toValue $ path ns

380 link = toValue $ path ns

378 H.li $ H.a ! href link ! class_ "code" $ n

381 H.li $ H.a ! href link ! class_ "code" $ n

384

387

385-- | Generates a HTML file for a namespace and its contents.

388-- | Generates a HTML file for a namespace and its contents.

386-- The location for e.g. Prelude.Algebra is <base>/Prelude/Algebra.html

389-- The location for e.g. Prelude.Algebra is <base>/Prelude/Algebra.html

387−createNsDoc :: NsDict -- ^ Information about other namespaces

390+createNsDoc :: IState -- ^ Needed to determine the types of names

388 -> NsName -- ^ The name of the namespace to

391 -> NsName -- ^ The name of the namespace to

389 -- create documentation for

392 -- create documentation for

390 -> NsInfo -- ^ The contents of the namespace

393 -> NsInfo -- ^ The contents of the namespace

391 -> FilePath -- ^ The base directory to which

394 -> FilePath -- ^ The base directory to which

392 -- documentation will be written.

395 -- documentation will be written.

393 -> IO ()

396 -> IO ()

394−createNsDoc nsd ns content out =

397+createNsDoc ist ns content out =

395− do let tpath = out </> (genRelNsPath ns "ns.html")

398+ do let tpath = out </> "docs" </> (genRelNsPath ns "html")

396− dir = takeDirectory tpath

399+ dir = takeDirectory tpath

397− file = takeFileName tpath

400+ file = takeFileName tpath

398− nonHidden (_, _, Hidden) = False

401+ visible (_, _, Hidden) = False

399− nonHidden _ = True

402+ visible _ = True

400− haveDocs (_, Nothing, _) = []

403+ haveDocs (_, Just d, _) = [d]

401− haveDocs (_, Just d, _) = [d]

404+ haveDocs _ = []

402− -- Do not document private members

405+ -- Do not document private members

403− content' = filter nonHidden content

406+ content' = filter visible content

404− -- We cannot do anything without a Doc

407+ -- We cannot do anything without a Doc

405− content'' = concatMap haveDocs content'

408+ content'' = concatMap haveDocs content'

406 createDirectoryIfMissing True dir

409 createDirectoryIfMissing True dir

407 (path, h) <- openTempFile dir file

410 (path, h) <- openTempFile dir file

408 BS2.hPut h $ renderHtml $ wrapper (Just ns) $ do

411 BS2.hPut h $ renderHtml $ wrapper (Just ns) $ do

409 H.h1 $ toHtml (nsName2Str ns)

412 H.h1 $ toHtml (nsName2Str ns)

410− H.dl ! class_ "decls" $ forM_ content'' (createOtherDoc nsd)

413+ H.dl ! class_ "decls" $ forM_ content'' (createOtherDoc ist)

411 hClose h

414 hClose h

412 renameFile path tpath

415 renameFile path tpath

413

416

416genRelNsPath :: NsName -- ^ Namespace to generate a path for

419genRelNsPath :: NsName -- ^ Namespace to generate a path for

417 -> String -- ^ Extension suffix

420 -> String -- ^ Extension suffix

418 -> FilePath

421 -> FilePath

419−genRelNsPath ns suffix = subpath ns <.> suffix

422+genRelNsPath ns suffix = nsName2Str ns <.> suffix

420−

421− where subpath = L.foldl1' (</>) . LS.splitOn "." . nsName2Str

422

423

424

424-- | Generates a HTML type signature with proper tags

425-- | Generates a HTML type signature with proper tags

425-- TODO: Turn docstrings into title attributes more robustly

426-- TODO: Turn docstrings into title attributes more robustly

426−genTypeHeader :: NsDict -- ^ Information about namespaces

427+genTypeHeader :: IState -- ^ Needed to determine the types of names

427 -> FunDoc -- ^ Type to generate type declaration for

428 -> FunDoc -- ^ Type to generate type declaration for

428 -> H.Html -- ^ Resulting HTML

429 -> H.Html -- ^ Resulting HTML

429−genTypeHeader nsd (FD n _ args ftype _) = do

430+genTypeHeader ist (FD n _ args ftype _) = do

431+ H.span ! class_ (toValue $ "name " ++ getType n)

430− H.span ! class_ "name" ! title (toValue $ show n) $ toHtml $ name $ nsroot n

432+ ! title (toValue $ show n)

431− " : "

433+ $ toHtml $ name $ nsroot n

434+ H.span ! class_ "word" $ do nbsp; ":"; nbsp

432− preEscapedToHtml htmlSignature

435+ H.span ! class_ "signature" $ preEscapedToHtml htmlSignature

433

436

434 where

437 where

435 htmlSignature = displayDecorated decorator $ renderCompact signature

438 htmlSignature = displayDecorated decorator $ renderCompact signature

437 names = [ n | (n@(UN n'), _, _, _) <- args,

440 names = [ n | (n@(UN n'), _, _, _) <- args,

438 not (T.isPrefixOf (txt "__") n') ]

441 not (T.isPrefixOf (txt "__") n') ]

439

442

440− decorator (AnnName n _ _ _) str | str /= show (nsroot n) = str

443+ decorator AnnConstData str = htmlSpan str "data" str

441− decorator (AnnName n _ _ _) str | filterName n, isFun n = do

444+ decorator AnnConstType str = htmlSpan str "type" str

442− R.renderHtml $ H.a ! class_ "name"

445+ decorator AnnKeyword str = htmlSpan "" "keyword" str

443− ! title (toValue $ show n) ! href (toValue $ link n)

444− $ toHtml $ str

445− decorator (AnnName n _ _ _) str | filterName n = do

446− R.renderHtml $ H.a ! class_ "type"

447− ! title (toValue $ show n) ! href (toValue $ link n)

448− $ toHtml $ str

449− decorator (AnnBoundName n _) str | Just t <- M.lookup n docs = do

446+ decorator (AnnBoundName n i) str | Just t <- M.lookup n docs =

450− R.renderHtml $ H.span ! class_ "arg" ! title (toValue t)

447+ let cs = (if i then "implicit " else "") ++ "documented boundvar"

451− $ toHtml $ str

448+ in htmlSpan t cs str

449+ decorator (AnnBoundName _ i) str =

450+ let cs = (if i then "implicit " else "") ++ "boundvar"

451+ in htmlSpan "" cs str

452+ decorator (AnnName n _ _ _) str

453+ | filterName n = htmlLink (show n) (getType n) (link n) str

454+ | otherwise = htmlSpan "" (getType n) str

455+ decorator (AnnTextFmt BoldText) str = "" ++ str ++ ""

456+ decorator (AnnTextFmt UnderlineText) str = "" ++ str ++ ""

457+ decorator (AnnTextFmt ItalicText) str = "" ++ str ++ ""

452 decorator _ str = str

458 decorator _ str = str

453

459

460+ htmlSpan :: String -> String -> String -> String

461+ htmlSpan t cs str = do

462+ R.renderHtml $ H.span ! class_ (toValue cs)

463+ ! title (toValue t)

464+ $ toHtml str

465+ htmlLink :: String -> String -> String -> String -> String

466+ htmlLink t cs a str = do

467+ R.renderHtml $ H.a ! class_ (toValue cs)

468+ ! title (toValue t) ! href (toValue a)

469+ $ toHtml str

470+

454 docs = M.fromList $ mapMaybe docExtractor args

471 docs = M.fromList $ mapMaybe docExtractor args

455 docExtractor (_, _, _, Nothing) = Nothing

472 docExtractor (_, _, _, Nothing) = Nothing

456− docExtractor (n, _, _, Just d) = Just (n, doc2Txt d)

473+ docExtractor (n, _, _, Just d) = Just (n, doc2Str d)

457 -- TODO: Remove tags more robustly

474 -- TODO: Remove tags more robustly

458− doc2Txt d = let dirty = renderMarkup $ contents $ renderDoc $ d

475+ doc2Str d = let dirty = renderMarkup $ contents $ renderDoc $ d

459 in take (length dirty - 8) $ drop 3 dirty

476 in take (length dirty - 8) $ drop 3 dirty

460

477

461 name (NS n ns) = show (NS (sUN $ name n) ns)

478 name (NS n ns) = show (NS (sUN $ name n) ns)

464 then '(':(n' ++ ")")

481 then '(':(n' ++ ")")

465 else n'

482 else n'

466

483

467− link n = let path = genRelNsPath (getNs n) "ns.html"

484+ link n = let path = genRelNsPath (getNs n) "html"

468 in path ++ "#" ++ (show n)

485 in path ++ "#" ++ (show n)

469

486

470− isFun n =

487+ getType :: Name -> String

471− let ns = getNs n

488+ getType n = let ctxt = tt_ctxt ist

472− in case M.lookup ns nsd of

489+ in case () of

473− Nothing -> False -- Should never happen

490+ _ | isDConName n ctxt -> "constructor"

474− Just nsi -> case L.find (\(n', d, a) -> n == n') nsi of

491+ _ | isFnName n ctxt -> "function"

475− Just (_, Just (FunDoc _), _) -> True

492+ _ | isTConName n ctxt -> "type"

476− _ -> False

493+ _ | otherwise -> ""

477

494

478-- | Generates HTML documentation for a function.

495-- | Generates HTML documentation for a function.

479−createFunDoc :: NsDict -- ^ Information about other namespaces

496+createFunDoc :: IState -- ^ Needed to determine the types of names

480 -> FunDoc -- ^ Function to generate block for

497 -> FunDoc -- ^ Function to generate block for

481 -> H.Html -- ^ Resulting HTML

498 -> H.Html -- ^ Resulting HTML

482−createFunDoc nsd fd@(FD name docstring args ftype fixity) = do

499+createFunDoc ist fd@(FD name docstring args ftype fixity) = do

483− H.dt ! (A.id $ toValue $ show name) $ genTypeHeader nsd fd

500+ H.dt ! (A.id $ toValue $ show name) $ genTypeHeader ist fd

484 H.dd $ do

501 H.dd $ do

485 (if nullDocstring docstring then Empty else renderDoc docstring)

502 (if nullDocstring docstring then Empty else renderDoc docstring)

486 let args' = filter (\(_, _, _, d) -> isJust d) args

503 let args' = filter (\(_, _, _, d) -> isJust d) args

510

527

511-- | Generates HTML documentation for any Docs type

528-- | Generates HTML documentation for any Docs type

512-- TODO: Generate actual signatures for typeclasses

529-- TODO: Generate actual signatures for typeclasses

513−createOtherDoc :: NsDict -- ^ Information about other namespaces

530+createOtherDoc :: IState -- ^ Needed to determine the types of names

514 -> Docs -- ^ Namespace item to generate HTML block for

531 -> Docs -- ^ Namespace item to generate HTML block for

515 -> H.Html -- ^ Resulting HTML

532 -> H.Html -- ^ Resulting HTML

516−createOtherDoc nsd (FunDoc fd) = createFunDoc nsd fd

533+createOtherDoc ist (FunDoc fd) = createFunDoc ist fd

517

534

518−createOtherDoc nsd (ClassDoc n docstring fds) = do

535+createOtherDoc ist (ClassDoc n docstring fds) = do

519 H.dt ! (A.id $ toValue $ show n) $ do

536 H.dt ! (A.id $ toValue $ show n) $ do

520− "class "

537+ H.span ! class_ "word" $ do "class"; nbsp

538+ H.span ! class_ "name type"

539+ ! title (toValue $ show n)

521− toHtml $ show n

540+ $ toHtml $ name $ nsroot n

541+ H.span ! class_ "signature" $ nbsp

522 H.dd $ do

542 H.dd $ do

523 (if nullDocstring docstring then Empty else renderDoc docstring)

543 (if nullDocstring docstring then Empty else renderDoc docstring)

524− H.dl ! class_ "decls" $ forM_ fds (createFunDoc nsd)

544+ H.dl ! class_ "decls" $ forM_ fds (createFunDoc ist)

545+

546+ where name (NS n ns) = show (NS (sUN $ name n) ns)

547+ name n = let n' = show n

548+ in if (head n') `elem` opChars

549+ then '(':(n' ++ ")")

550+ else n'

525

551

526−createOtherDoc nsd (DataDoc fd@(FD n docstring args _ _) fds) = do

552+createOtherDoc ist (DataDoc fd@(FD n docstring args _ _) fds) = do

527 H.dt ! (A.id $ toValue $ show n) $ do

553 H.dt ! (A.id $ toValue $ show n) $ do

528− "data "

554+ H.span ! class_ "word" $ do "data"; nbsp

529− genTypeHeader nsd fd

555+ genTypeHeader ist fd

530 H.dd $ do

556 H.dd $ do

531 (if nullDocstring docstring then Empty else renderDoc docstring)

557 (if nullDocstring docstring then Empty else renderDoc docstring)

532 let args' = filter (\(_, _, _, d) -> isJust d) args

558 let args' = filter (\(_, _, _, d) -> isJust d) args

533 if not $ null args'

559 if not $ null args'

534 then H.dl $ forM_ args' genArg

560 then H.dl $ forM_ args' genArg

535 else Empty

561 else Empty

536− H.dl ! class_ "decls" $ forM_ fds (createFunDoc nsd)

562+ H.dl ! class_ "decls" $ forM_ fds (createFunDoc ist)

537

563

538 where genArg (_, _, _, Nothing) = Empty

564 where genArg (_, _, _, Nothing) = Empty

539 genArg (name, _, _, Just docstring) = do

565 genArg (name, _, _, Just docstring) = do

546 -> H.Html -- ^ Inner HTML

572 -> H.Html -- ^ Inner HTML

547 -> H.Html

573 -> H.Html

548wrapper ns inner =

574wrapper ns inner =

549− let (index, str, nestings) = extract ns

575+ let (index, str) = extract ns

550− base = if nestings > 0

576+ base = if index then "" else "../"

551− then foldl1 (</>) (replicate nestings "..")

577+ styles = base ++ "styles.css" :: String

552− else "."

578+ indexPage = base ++ "index.html" :: String

553 in H.docTypeHtml $ do

579 in H.docTypeHtml $ do

554 H.head $ do

580 H.head $ do

555 H.title $ do

581 H.title $ do

557 if index then " Index" else do

583 if index then " Index" else do

558 ": "

584 ": "

559 toHtml str

585 toHtml str

560− H.base ! href (toValue base)

561− H.link ! type_ "text/css" ! rel "stylesheet" ! href "styles.css"

586+ H.link ! type_ "text/css" ! rel "stylesheet"

587+ ! href (toValue styles)

562 H.body ! class_ (if index then "index" else "namespace") $ do

588 H.body ! class_ (if index then "index" else "namespace") $ do

563 H.div ! class_ "wrapper" $ do

589 H.div ! class_ "wrapper" $ do

564 H.header $ do

590 H.header $ do

566 if index then Empty else do

592 if index then Empty else do

567 ": "

593 ": "

568 toHtml str

594 toHtml str

569− H.nav $ H.a ! href "index.html" $ "Index"

595+ H.nav $ H.a ! href (toValue indexPage) $ "Index"

570 H.div ! class_ "container" $ inner

596 H.div ! class_ "container" $ inner

571 H.footer $ do

597 H.footer $ do

572 "Produced by IdrisDoc version "

598 "Produced by IdrisDoc version "

573 toHtml version

599 toHtml version

574

600

575− where extract (Just ns) = let nestings = if null ns then 1 else length ns

576− in (False, nsName2Str ns, nestings-1)

601+ where extract (Just ns) = (False, nsName2Str ns)

577− extract _ = (True, "", 0)

602+ extract _ = (True, "")

603+

604+

605+-- | Non-break space character

606+nbsp :: H.Html

607+nbsp = preEscapedToHtml (" " :: String)

578

608

579

609

580-- | Copies IdrisDoc dependencies such as stylesheets to a directory

610-- | Copies IdrisDoc dependencies such as stylesheets to a directory

607 where reader h = let converter = text2DocInfo . E.decodeUtf8

637 where reader h = let converter = text2DocInfo . E.decodeUtf8

608 in converter `fmap` BS.hGetContents h

638 in converter `fmap` BS.hGetContents h

609 onlyValid out ns s = do s' <- s

639 onlyValid out ns s = do s' <- s

610− let end = (genRelNsPath ns "ns.html")

640+ let end = (genRelNsPath ns "html")

611 exists <- doesFileExist $ out </> end

641 exists <- doesFileExist $ out </> end

612 if exists then return $ S.insert ns s'

642 if exists then return $ S.insert ns s'

613 else s

643 else s