585ea9f · Idris-dev · git.iko.soy

4-- | Generation of HTML documentation for Idris code

5module Idris.IdrisDoc (generateDocs) where

6

7−import Idris.Core.TT (Name (..), SpecialName (..), txt, str, nsroot)

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

8+ txt, str, nsroot)

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

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

9 Accessibility (..))

10 Accessibility (..))

11+import Idris.ParseHelpers (opChars)

10import Idris.AbsSyntax

12import Idris.AbsSyntax

11import Idris.Docs

13import Idris.Docs

14+import Idris.Docstrings (nullDocstring)

12

15

13import Paths_idris (getDataFileName)

16import Paths_idris (getDataFileName)

14

17

16import Control.Monad.Trans.Error

19import Control.Monad.Trans.Error

17import Control.Monad.Trans.State.Strict

20import Control.Monad.Trans.State.Strict

18

21

22+import Data.Maybe

23+

19import qualified Data.ByteString as BS

24import qualified Data.ByteString as BS

20import qualified Data.ByteString.Lazy as BS2

25import qualified Data.ByteString.Lazy as BS2

21import qualified Data.Text.Encoding as E

26import qualified Data.Text.Encoding as E

22import qualified Data.List as L

27import qualified Data.List as L

23import qualified Data.List.Split as LS

28import qualified Data.List.Split as LS

24import qualified Data.Map as M hiding ((!))

29import qualified Data.Map as M hiding ((!))

30+import qualified Data.Ord (compare)

25import qualified Data.Set as S

31import qualified Data.Set as S

26import qualified Data.Text as T

32import qualified Data.Text as T

27

33

30import System.FilePath

36import System.FilePath

31import System.Directory

37import System.Directory

32

38

39+import Cheapskate.Html (renderDoc)

40+import Text.PrettyPrint.Annotated.Leijen (displayDecorated, renderCompact)

41+

33−import Text.Blaze (toValue)

42+import Text.Blaze (toValue, contents)

43+import Text.Blaze.Internal (MarkupM (Empty))

34−import Text.Blaze.Html5 ((!), toHtml)

44+import Text.Blaze.Html5 ((!), toHtml, preEscapedToHtml)

35import qualified Text.Blaze.Html5 as H

45import qualified Text.Blaze.Html5 as H

36−import Text.Blaze.Html5.Attributes

46+import Text.Blaze.Html5.Attributes as A

37import Text.Blaze.Html.Renderer.Utf8 (renderHtml)

47import Text.Blaze.Html.Renderer.Utf8 (renderHtml)

48+import qualified Text.Blaze.Html.Renderer.String as R

49+import Text.Blaze.Renderer.String (renderMarkup)

38

50

39-- ---------------------------------------------------------------- [ Public ]

51-- ---------------------------------------------------------------- [ Public ]

40

52

41−-- | Generates HTML documentation for a series of loaded namespaces and their dependencies.

53+-- | Generates HTML documentation for a series of loaded namespaces

54+-- and their dependencies.

42generateDocs :: IState -- ^ IState where all necessary information is

55generateDocs :: IState -- ^ IState where all necessary information is

43 -- extracted from.

56 -- extracted from.

44 -> [Name] -- ^ List of namespaces to generate

57 -> [Name] -- ^ List of namespaces to generate

130

143

131

144

132-- | Removes loose class methods and data constructors,

145-- | Removes loose class methods and data constructors,

133−-- leaving them documented only under their parent.

146+-- leaving them documented only under their parent.

134removeOrphans :: [NsItem] -- ^ List to remove orphans from

147removeOrphans :: [NsItem] -- ^ List to remove orphans from

135 -> [NsItem] -- ^ Orphan-free list

148 -> [NsItem] -- ^ Orphan-free list

136removeOrphans list =

149removeOrphans list =

214

227

215

228

216-- | Predicate saying whether a Name possibly may have docs defined

229-- | Predicate saying whether a Name possibly may have docs defined

217−-- | Without this, getDocs from Idris.Docs may fail a pattern match.

230+-- Without this, getDocs from Idris.Docs may fail a pattern match.

218mayHaveDocs :: Name -- ^ The Name to test

231mayHaveDocs :: Name -- ^ The Name to test

219 -> Bool -- ^ The result

232 -> Bool -- ^ The result

220mayHaveDocs (UN _) = True

233mayHaveDocs (UN _) = True

234

247

235

248

236-- | Extracts names referred from a type.

249-- | Extracts names referred from a type.

237−-- The covering of all PTerms ensures that we avoid unanticipated cases.

250+-- The covering of all PTerms ensures that we avoid unanticipated cases, though

238−-- All of them are probably not needed.

251+-- all of them are not needed. The author just did not know which!

239-- TODO: Remove unnecessary cases

252-- TODO: Remove unnecessary cases

240extractPTermNames :: PTerm -- ^ Where to extract names from

253extractPTermNames :: PTerm -- ^ Where to extract names from

241 -> [Name] -- ^ Extracted names

254 -> [Name] -- ^ Extracted names

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

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

320-- is attempted.

333-- is attempted.

321-- TODO: Ensure the merge always succeeds.

334-- TODO: Ensure the merge always succeeds.

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

335+-- Currently the content of '<builtins>.ns.html' may change between

323−-- thus not always containing all items referred from other .ns.html files.

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

337+-- .ns.html files.

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

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

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

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

326 -- documentation will be written.

340 -- documentation will be written.

335 " already in use for other than IdrisDoc."

349 " already in use for other than IdrisDoc."

336 else do

350 else do

337 createDirectoryIfMissing True out

351 createDirectoryIfMissing True out

338− foldl (docGen out) (return ()) (M.toList nsd)

352+ foldl docGen (return ()) (M.toList nsd)

339−-- if new then putStrLn "Creating IdrisDoc index"

340−-- else putStrLn "Updating IdrisDoc index"

341 createIndex nss out

353 createIndex nss out

342 writeDocInfo out (docInfo' { namespaces = nss })

354 writeDocInfo out (docInfo' { namespaces = nss })

343 copyDependencies out

355 copyDependencies out

344 return $ Right ()

356 return $ Right ()

345

357

346− where docGen out io (n, c) =

347− do io

348−-- putStrLn $ "Creating IdrisDoc for '" ++ (nsName2Str n) ++ "'"

349− createNsDoc n c out

358+ where docGen io (n, c) = do io; createNsDoc nsd n c out

350

359

351

360

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

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

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

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

362 H.h1 $ "Namespaces"

371 H.h1 $ "Namespaces"

363 H.ul ! class_ "names" $ do

372 H.ul ! class_ "names" $ do

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

373+ let path ns = genRelNsPath ns "ns.html"

365− item ns = do let n = toHtml $ nsName2Str ns

374+ item ns = do let n = toHtml $ nsName2Str ns

366− link = toValue $ path ns

375+ link = toValue $ path ns

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

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

377+ sort = L.sortBy (\n1 n2 -> reverse n1 `compare` reverse n2)

368− forM_ (S.toList nss) item

378+ forM_ (sort $ S.toList nss) item

369 hClose h

379 hClose h

370 renameFile path (out </> "index.html")

380 renameFile path (out </> "index.html")

371

381

372

382

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

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

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

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

385+createNsDoc :: NsDict -- ^ Information about other namespaces

375−createNsDoc :: NsName -- ^ The name of the namespace to

386+ -> NsName -- ^ The name of the namespace to

376 -- create documentation for

387 -- create documentation for

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

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

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

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

379 -- documentation will be written.

390 -- documentation will be written.

380 -> IO ()

391 -> IO ()

381−createNsDoc ns content out =

392+createNsDoc nsd ns content out =

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

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

383 dir = takeDirectory tpath

394 dir = takeDirectory tpath

384 file = takeFileName tpath

395 file = takeFileName tpath

385 nonHidden (_, _, Hidden) = False

396 nonHidden (_, _, Hidden) = False

386 nonHidden _ = True

397 nonHidden _ = True

387− haveDocs (_, Nothing, _) = False

398+ haveDocs (_, Nothing, _) = []

388− haveDocs _ = True

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

389 -- Do not document private members

400 -- Do not document private members

390 content' = filter nonHidden content

401 content' = filter nonHidden content

391 -- We cannot do anything without a Doc

402 -- We cannot do anything without a Doc

392− content'' = filter haveDocs content'

403+ content'' = concatMap haveDocs content'

393 createDirectoryIfMissing True dir

404 createDirectoryIfMissing True dir

394 (path, h) <- openTempFile dir file

405 (path, h) <- openTempFile dir file

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

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

396 H.h1 $ toHtml (nsName2Str ns)

407 H.h1 $ toHtml (nsName2Str ns)

397− forM_ content'' (\(n,_,_) -> H.p $ toHtml $ show n)

408+ H.dl ! class_ "decls" $ forM_ content'' (createOtherDoc nsd)

398 hClose h

409 hClose h

399 renameFile path tpath

410 renameFile path tpath

400

411

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

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

409

420

410

421

422+-- | Generates a HTML type signature with proper tags

423+-- TODO: Turn docstrings into title attributes more robustly

424+genTypeHeader :: NsDict -- ^ Information about namespaces

425+ -> FunDoc -- ^ Type to generate type declaration for

426+ -> H.Html -- ^ Resulting HTML

427+genTypeHeader nsd (FD n _ args ftype _) = do

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

429+ " : "

430+ preEscapedToHtml htmlSignature

431+

432+ where

433+ htmlSignature = displayDecorated decorator $ renderCompact signature

434+ signature = pprintPTerm False [] names ftype

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

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

437+

438+ decorator (AnnName n _ _ _) str | filterName n, isFun n = do

439+ R.renderHtml $ H.a ! class_ "name"

440+ ! title (toValue $ show n) ! href (toValue $ link n)

441+ $ toHtml $ show $ nsroot n

442+ decorator (AnnName n _ _ _) str | filterName n = do

443+ R.renderHtml $ H.a ! class_ "type"

444+ ! title (toValue $ show n) ! href (toValue $ link n)

445+ $ toHtml $ show $ nsroot n

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

447+ R.renderHtml $ H.span ! class_ "arg" ! title (toValue t)

448+ $ toHtml $ show n

449+ decorator _ str = str

450+

451+ docs = M.fromList $ mapMaybe docExtractor args

452+ docExtractor (_, _, _, Nothing) = Nothing

453+ docExtractor (n, _, _, Just d) = Just (n, doc2Txt d)

454+ -- TODO: Remove <p> tags more robustly

455+ doc2Txt d = let dirty = renderMarkup $ contents $ renderDoc $ d

456+ in take (length dirty - 8) $ drop 3 dirty

457+

458+ name (NS n ns) = show (NS (sUN $ name n) ns)

459+ name n = let n' = show n

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

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

462+ else n'

463+

464+ link n = let path = genRelNsPath (getNs n) "ns.html"

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

466+

467+ isFun n =

468+ let ns = getNs n

469+ in case M.lookup ns nsd of

470+ Nothing -> False -- Should never happen

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

472+ Just (_, Just (FunDoc _), _) -> True

473+ _ -> False

474+

475+-- | Generates HTML documentation for a function.

476+createFunDoc :: NsDict -- ^ Information about other namespaces

477+ -> FunDoc -- ^ Function to generate block for

478+ -> H.Html -- ^ Resulting HTML

479+createFunDoc nsd fd@(FD name docstring args ftype fixity) = do

480+ H.dt ! (A.id $ toValue $ show name) $ genTypeHeader nsd fd

481+ H.dd $ do

482+ (if nullDocstring docstring then Empty else renderDoc docstring)

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

484+ if (not $ null args') || (isJust fixity)

485+ then H.dl $ do

486+ if (isJust fixity) then do

487+ H.dt ! class_ "fixity" $ "Fixity"

488+ let f = fromJust fixity

489+ H.dd ! class_ "fixity" ! title (toValue $ show f) $ genFix f

490+ else Empty

491+ forM_ args' genArg

492+ else Empty

493+

494+ where genFix (Infixl {prec=p}) =

495+ toHtml $ "Left associative, precedence " ++ show p

496+ genFix (Infixr {prec=p}) =

497+ toHtml $ "Left associative, precedence " ++ show p

498+ genFix (InfixN {prec=p}) =

499+ toHtml $ "Non-associative, precedence " ++ show p

500+ genFix (PrefixN {prec=p}) =

501+ toHtml $ "Prefix, precedence " ++ show p

502+ genArg (_, _, _, Nothing) = Empty

503+ genArg (name, _, _, Just docstring) = do

504+ H.dt $ toHtml $ show name

505+ H.dd $ renderDoc docstring

506+

507+

508+-- | Generates HTML documentation for any Docs type

509+-- TODO: Generate actual signatures for typeclasses

510+createOtherDoc :: NsDict -- ^ Information about other namespaces

511+ -> Docs -- ^ Namespace item to generate HTML block for

512+ -> H.Html -- ^ Resulting HTML

513+createOtherDoc nsd (FunDoc fd) = createFunDoc nsd fd

514+createOtherDoc nsd (ClassDoc n docstring fds) = do

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

516+ "class "

517+ toHtml $ show n

518+ H.dd $ do

519+ (if nullDocstring docstring then Empty else renderDoc docstring)

520+ H.dl ! class_ "decls" $ forM_ fds (createFunDoc nsd)

521+createOtherDoc nsd (DataDoc fd@(FD n docstring args _ _) fds) = do

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

523+ "data "

524+ genTypeHeader nsd fd

525+ H.dd $ do

526+ (if nullDocstring docstring then Empty else renderDoc docstring)

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

528+ if not $ null args'

529+ then H.dl $ forM_ args' genArg

530+ else Empty

531+ H.dl ! class_ "decls" $ forM_ fds (createFunDoc nsd)

532+

533+ where genArg (_, _, _, Nothing) = Empty

534+ genArg (name, _, _, Just docstring) = do

535+ H.dt $ toHtml $ show name

536+ H.dd $ renderDoc docstring

537+

538+

411-- | Generates everything but the actual content of the page

539-- | Generates everything but the actual content of the page

412wrapper :: Maybe NsName -- ^ Namespace name, unless it is the index

540wrapper :: Maybe NsName -- ^ Namespace name, unless it is the index

413 -> H.Html -- ^ Inner HTML

541 -> H.Html -- ^ Inner HTML

430 H.div ! class_ "wrapper" $ do

558 H.div ! class_ "wrapper" $ do

431 H.header $ do

559 H.header $ do

432 H.strong "IdrisDoc"

560 H.strong "IdrisDoc"

433− if index then "" else do

561+ if index then Empty else do

434 ": "

562 ": "

435 toHtml str

563 toHtml str

436 H.nav $ H.a ! href "index.html" $ "Index"

564 H.nav $ H.a ! href "index.html" $ "Index"