{-|
Module      : Idris.IdrisDoc
Description : Generation of HTML documentation for Idris code

License     : BSD3
Maintainer  : The Idris Community.
-}
{-# LANGUAGE OverloadedStrings, PatternGuards #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
module Idris.IdrisDoc (generateDocs) where

import Idris.AbsSyntax
import Idris.Core.Evaluate (Accessibility(..), ctxtAlist, isDConName, isFnName,
                            isTConName, lookupDefAcc)
import Idris.Core.TT (Name(..), OutputAnnotation(..), TextFormatting(..),
                      constIsType, nsroot, sUN, str, toAlist, txt)
import Idris.Docs
import Idris.Docstrings (nullDocstring)
import qualified Idris.Docstrings as Docstrings
import Idris.Options
import Idris.Parser.Ops (opChars)
import IRTS.System (getIdrisDataFileByName)

import Control.Applicative ((<|>))
import Control.Monad (forM_)
import Control.Monad.Trans.Except
import Control.Monad.Trans.State.Strict
import qualified Data.ByteString.Lazy as BS2
import qualified Data.List as L
import qualified Data.Map as M hiding ((!))
import Data.Maybe
import Data.Monoid (mempty)
import qualified Data.Set as S
import qualified Data.Text as T
import System.Directory
import System.FilePath
import System.IO
import System.IO.Error
import Text.Blaze (contents, toValue)
import qualified Text.Blaze.Html.Renderer.String as R
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
import Text.Blaze.Html5 (preEscapedToHtml, toHtml, (!))
import qualified Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes as A
import Text.Blaze.Renderer.String (renderMarkup)
import Text.PrettyPrint.Annotated.Leijen (displayDecorated, renderCompact)

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

-- | Generates HTML documentation for a series of loaded namespaces
--   and their dependencies.
generateDocs :: IState   -- ^ IState where all necessary information is
                         --   extracted from.
             -> [Name]   -- ^ List of namespaces to generate
                         --   documentation for.
             -> FilePath -- ^ The directory to which documentation will
                         --   be written.
             -> IO (Either String ())
generateDocs :: IState -> [Name] -> FilePath -> IO (Either FilePath ())
generateDocs ist :: IState
ist nss' :: [Name]
nss' out :: FilePath
out =
  do let nss :: [NsName]
nss     = (Name -> NsName) -> [Name] -> [NsName]
forall a b. (a -> b) -> [a] -> [b]
map Name -> NsName
toNsName [Name]
nss'
     NsDict
docs       <- IState -> [NsName] -> IO NsDict
fetchInfo IState
ist [NsName]
nss
     let (c :: Int
c, io :: IO ()
io) = ((Int, IO ()) -> NsName -> (Int, IO ()))
-> (Int, IO ()) -> [NsName] -> (Int, IO ())
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (NsDict -> (Int, IO ()) -> NsName -> (Int, IO ())
forall a a.
Num a =>
Map NsName a -> (a, IO ()) -> NsName -> (a, IO ())
checker NsDict
docs) (0, () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) [NsName]
nss
     IO ()
io
     if Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [NsName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NsName]
nss
        then IO (Either FilePath ())
-> (IOError -> IO (Either FilePath ())) -> IO (Either FilePath ())
forall a. IO a -> (IOError -> IO a) -> IO a
catchIOError (IState -> NsDict -> FilePath -> IO (Either FilePath ())
createDocs IState
ist NsDict
docs FilePath
out) (FilePath -> IO (Either FilePath ())
err (FilePath -> IO (Either FilePath ()))
-> (IOError -> FilePath) -> IOError -> IO (Either FilePath ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> FilePath
forall a. Show a => a -> FilePath
show)
        else FilePath -> IO (Either FilePath ())
err "No namespaces to generate documentation for"

  where checker :: Map NsName a -> (a, IO ()) -> NsName -> (a, IO ())
checker docs :: Map NsName a
docs st :: (a, IO ())
st ns :: NsName
ns | NsName -> Map NsName a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member NsName
ns Map NsName a
docs = (a, IO ())
st
        checker docs :: Map NsName a
docs (c :: a
c, io :: IO ()
io) ns :: NsName
ns = (a
ca -> a -> a
forall a. Num a => a -> a -> a
+1, do ()
prev <- IO ()
io; NsName -> IO ()
warnMissing NsName
ns)
        warnMissing :: NsName -> IO ()
warnMissing ns :: NsName
ns =
          FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Warning: Ignoring empty or non-existing namespace '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                     (NsName -> FilePath
nsName2Str NsName
ns) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "'"

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

-- | Either an error message or a result
type Failable = Either String

-- | Internal representation of a fully qualified namespace name
type NsName = [T.Text]

-- | All information to be documented about a single namespace member
type NsItem = (Name, Maybe Docs, Accessibility)

-- | Docstrings containing fully elaborated term annotations
type FullDocstring = Docstrings.Docstring Docstrings.DocTerm

-- | All information to be documented about a namespace
data NsInfo = NsInfo { NsInfo -> Maybe FullDocstring
nsDocstring :: Maybe FullDocstring,
                       NsInfo -> [NsItem]
nsContents :: [NsItem]
                     }

-- | A map from namespace names to information about them
type NsDict = M.Map NsName NsInfo

-- --------------------------------------------------------------- [ Utility ]

-- | Make an error message
err :: String -> IO (Failable ())
err :: FilePath -> IO (Either FilePath ())
err s :: FilePath
s = Either FilePath () -> IO (Either FilePath ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath () -> IO (Either FilePath ()))
-> Either FilePath () -> IO (Either FilePath ())
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath ()
forall a b. a -> Either a b
Left FilePath
s

-- | IdrisDoc version
version :: String
version :: FilePath
version = "1.0"

-- | Converts a Name into a [Text] corresponding to the namespace
--   part of a NS Name.
toNsName :: Name -- ^ Name to convert
         -> NsName
toNsName :: Name -> NsName
toNsName (UN n :: Text
n)    = [Text
n]
toNsName (NS n :: Name
n ns :: NsName
ns) = (Name -> NsName
toNsName Name
n) NsName -> NsName -> NsName
forall a. [a] -> [a] -> [a]
++ NsName
ns
toNsName _         = []


-- | Retrieves the namespace part of a Name
getNs :: Name -- ^ Name to retrieve namespace for
      -> NsName
getNs :: Name -> NsName
getNs (NS _ ns :: NsName
ns) = NsName
ns
getNs _         = []


-- | String to replace for the root namespace
rootNsStr :: String
rootNsStr :: FilePath
rootNsStr = "[builtins]"


-- | Converts a NsName to string form
nsName2Str :: NsName -- ^ NsName to convert
           -> String
nsName2Str :: NsName -> FilePath
nsName2Str n :: NsName
n = if NsName -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null NsName
n then FilePath
rootNsStr else NsName -> FilePath
name NsName
n

  where name :: NsName -> FilePath
name []       = []
        name [ns :: Text
ns]     = Text -> FilePath
str Text
ns
        name (ns :: Text
ns:nss :: NsName
nss) = (NsName -> FilePath
name NsName
nss) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ('.' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: Text -> FilePath
str Text
ns)

-- --------------------------------------------------------- [ Info Fetching ]

-- | Fetch info about namespaces and their contents
fetchInfo :: IState    -- ^ IState to fetch info from
          -> [NsName]  -- ^ List of namespaces to fetch info for
          -> IO NsDict -- ^ Mapping from namespace name to
                       --   info about its contents
fetchInfo :: IState -> [NsName] -> IO NsDict
fetchInfo ist :: IState
ist nss :: [NsName]
nss =
  do let originNss :: Set NsName
originNss  = [NsName] -> Set NsName
forall a. Ord a => [a] -> Set a
S.fromList [NsName]
nss
     NsDict
info          <- IState -> IO NsDict
nsDict IState
ist
     let accessible :: NsDict
accessible = (NsInfo -> NsInfo) -> NsDict -> NsDict
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((NsItem -> Bool) -> NsInfo -> NsInfo
filterContents NsItem -> Bool
filterInclude) NsDict
info
         nonOrphan :: NsDict
nonOrphan  = (NsInfo -> NsInfo) -> NsDict -> NsDict
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (([NsItem] -> [NsItem]) -> NsInfo -> NsInfo
updateContents [NsItem] -> [NsItem]
removeOrphans) NsDict
accessible
         nonEmpty :: NsDict
nonEmpty   = (NsInfo -> Bool) -> NsDict -> NsDict
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
not (Bool -> Bool) -> (NsInfo -> Bool) -> NsInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NsItem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([NsItem] -> Bool) -> (NsInfo -> [NsItem]) -> NsInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NsInfo -> [NsItem]
nsContents) NsDict
nonOrphan
         reachedNss :: Set NsName
reachedNss = NsDict -> Set NsName -> Set NsName -> Set NsName
traceNss NsDict
nonEmpty Set NsName
originNss Set NsName
forall a. Set a
S.empty
     NsDict -> IO NsDict
forall (m :: * -> *) a. Monad m => a -> m a
return (NsDict -> IO NsDict) -> NsDict -> IO NsDict
forall a b. (a -> b) -> a -> b
$ (NsName -> NsInfo -> Bool) -> NsDict -> NsDict
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\k :: NsName
k _ -> NsName -> Set NsName -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member NsName
k Set NsName
reachedNss) NsDict
nonEmpty
  where
    -- TODO: lensify
    filterContents :: (NsItem -> Bool) -> NsInfo -> NsInfo
filterContents p :: NsItem -> Bool
p (NsInfo md :: Maybe FullDocstring
md ns :: [NsItem]
ns) = Maybe FullDocstring -> [NsItem] -> NsInfo
NsInfo Maybe FullDocstring
md ((NsItem -> Bool) -> [NsItem] -> [NsItem]
forall a. (a -> Bool) -> [a] -> [a]
filter NsItem -> Bool
p [NsItem]
ns)
    updateContents :: ([NsItem] -> [NsItem]) -> NsInfo -> NsInfo
updateContents f :: [NsItem] -> [NsItem]
f x :: NsInfo
x = NsInfo
x { nsContents :: [NsItem]
nsContents = [NsItem] -> [NsItem]
f (NsInfo -> [NsItem]
nsContents NsInfo
x) }

-- | Removes loose interface methods and data constructors,
--   leaving them documented only under their parent.
removeOrphans :: [NsItem] -- ^ List to remove orphans from
              -> [NsItem] -- ^ Orphan-free list
removeOrphans :: [NsItem] -> [NsItem]
removeOrphans list :: [NsItem]
list =
  let children :: Set Name
children = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ (NsItem -> [Name]) -> [NsItem] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe (Docs' FullDocstring) -> [Name]
forall d. Maybe (Docs' d) -> [Name]
names (Maybe (Docs' FullDocstring) -> [Name])
-> (NsItem -> Maybe (Docs' FullDocstring)) -> NsItem -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(_, d :: Maybe (Docs' FullDocstring)
d, _) -> Maybe (Docs' FullDocstring)
d)) [NsItem]
list
  in  (NsItem -> Bool) -> [NsItem] -> [NsItem]
forall a. (a -> Bool) -> [a] -> [a]
filter (((Name -> Set Name -> Bool) -> Set Name -> Name -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
S.notMember Set Name
children) (Name -> Bool) -> (NsItem -> Name) -> NsItem -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(n :: Name
n, _, _) -> Name
n)) [NsItem]
list

  where names :: Maybe (Docs' d) -> [Name]
names (Just (DataDoc _ fds :: [FunDoc' d]
fds))                  = (FunDoc' d -> Name) -> [FunDoc' d] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\(FD n :: Name
n _ _ _ _) -> Name
n) [FunDoc' d]
fds
        names (Just (InterfaceDoc _ _ fds :: [FunDoc' d]
fds _ _ _ _ _ c :: Maybe (FunDoc' d)
c)) = (FunDoc' d -> Name) -> [FunDoc' d] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\(FD n :: Name
n _ _ _ _) -> Name
n) [FunDoc' d]
fds [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ (FunDoc' d -> Name) -> [FunDoc' d] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\(FD n :: Name
n _ _ _ _) -> Name
n) (Maybe (FunDoc' d) -> [FunDoc' d]
forall a. Maybe a -> [a]
maybeToList Maybe (FunDoc' d)
c)
        names _                                       = []

-- | Whether a Name names something which should be documented
filterName :: Name -- ^ Name to check
           -> Bool -- ^ Predicate result
filterName :: Name -> Bool
filterName (UN _)     = Bool
True
filterName (NS n :: Name
n _)   = Name -> Bool
filterName Name
n
filterName _          = Bool
False


-- | Whether a NsItem should be included in the documentation.
--   It must not be Hidden/Private and filterName must return True for the name.
--   Also it must have Docs -- without Docs, nothing can be done.
filterInclude :: NsItem -- ^ Accessibility to check
              -> Bool   -- ^ Predicate result
filterInclude :: NsItem -> Bool
filterInclude (name :: Name
name, Just _, Public) | Name -> Bool
filterName Name
name = Bool
True
filterInclude (name :: Name
name, Just _, Frozen) | Name -> Bool
filterName Name
name = Bool
True
filterInclude _                                        = Bool
False


-- | Finds all namespaces indirectly referred by a set of namespaces.
--   The NsItems of the namespaces are searched for references.
traceNss :: NsDict       -- ^ Mappings of namespaces and their contents
         -> S.Set NsName -- ^ Set of namespaces to trace
         -> S.Set NsName -- ^ Set of namespaces which has been traced
         -> S.Set NsName -- ^ Set of namespaces to trace and all traced one
traceNss :: NsDict -> Set NsName -> Set NsName -> Set NsName
traceNss nsd :: NsDict
nsd sT :: Set NsName
sT sD :: Set NsName
sD =
  let nsTracer :: NsName -> [Set NsName]
nsTracer ns :: NsName
ns | Just nsis :: NsInfo
nsis <- NsName -> NsDict -> Maybe NsInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NsName
ns NsDict
nsd = (NsItem -> Set NsName) -> [NsItem] -> [Set NsName]
forall a b. (a -> b) -> [a] -> [b]
map NsItem -> Set NsName
referredNss (NsInfo -> [NsItem]
nsContents NsInfo
nsis)
      nsTracer _                                 = [Set NsName
forall a. Set a
S.empty] -- Ignore
      reached :: Set NsName
reached     = [Set NsName] -> Set NsName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set NsName] -> Set NsName) -> [Set NsName] -> Set NsName
forall a b. (a -> b) -> a -> b
$ (NsName -> [Set NsName]) -> [NsName] -> [Set NsName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NsName -> [Set NsName]
nsTracer (Set NsName -> [NsName]
forall a. Set a -> [a]
S.toList Set NsName
sT)
      processed :: Set NsName
processed   = Set NsName -> Set NsName -> Set NsName
forall a. Ord a => Set a -> Set a -> Set a
S.union Set NsName
sT Set NsName
sD
      untraced :: Set NsName
untraced    = Set NsName -> Set NsName -> Set NsName
forall a. Ord a => Set a -> Set a -> Set a
S.difference Set NsName
reached Set NsName
processed
  in  if Set NsName -> Bool
forall a. Set a -> Bool
S.null Set NsName
untraced then Set NsName
processed
      else NsDict -> Set NsName -> Set NsName -> Set NsName
traceNss NsDict
nsd Set NsName
untraced Set NsName
processed


-- | Gets all namespaces directly referred by a NsItem
referredNss :: NsItem -- ^ The name to get all directly
                      --   referred namespaces for
            -> S.Set NsName
referredNss :: NsItem -> Set NsName
referredNss (_, Nothing, _) = Set NsName
forall a. Set a
S.empty
referredNss (n :: Name
n, Just d :: Docs' FullDocstring
d, _) =
  let fds :: [FunDoc' FullDocstring]
fds    = Docs' FullDocstring -> [FunDoc' FullDocstring]
forall d. Docs' d -> [FunDoc' d]
getFunDocs Docs' FullDocstring
d
      ts :: [PTerm]
ts     = (FunDoc' FullDocstring -> [PTerm])
-> [FunDoc' FullDocstring] -> [PTerm]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FunDoc' FullDocstring -> [PTerm]
forall d. FunDoc' d -> [PTerm]
types [FunDoc' FullDocstring]
fds
      names :: [Name]
names  = (PTerm -> [Name]) -> [PTerm] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (PTerm -> [Name]
extractPTermNames) [PTerm]
ts
  in  (Name -> NsName) -> Set Name -> Set NsName
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map Name -> NsName
getNs (Set Name -> Set NsName) -> Set Name -> Set NsName
forall a b. (a -> b) -> a -> b
$ [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList [Name]
names

  where getFunDocs :: Docs' d -> [FunDoc' d]
getFunDocs (FunDoc f :: FunDoc' d
f)                        = [FunDoc' d
f]
        getFunDocs (DataDoc f :: FunDoc' d
f fs :: [FunDoc' d]
fs)                    = FunDoc' d
fFunDoc' d -> [FunDoc' d] -> [FunDoc' d]
forall a. a -> [a] -> [a]
:[FunDoc' d]
fs
        getFunDocs (InterfaceDoc _ _ fs :: [FunDoc' d]
fs _ _ _ _ _ _) = [FunDoc' d]
fs
        getFunDocs (RecordDoc _ _ f :: FunDoc' d
f fs :: [FunDoc' d]
fs _)            = FunDoc' d
fFunDoc' d -> [FunDoc' d] -> [FunDoc' d]
forall a. a -> [a] -> [a]
:[FunDoc' d]
fs
        getFunDocs (NamedImplementationDoc _ fd :: FunDoc' d
fd)     = [FunDoc' d
fd]
        getFunDocs (ModDoc _ _)                      = []
        types :: FunDoc' d -> [PTerm]
types (FD _ _ args :: [(Name, PTerm, Plicity, Maybe d)]
args t :: PTerm
t _)                      = PTerm
tPTerm -> [PTerm] -> [PTerm]
forall a. a -> [a] -> [a]
:(((Name, PTerm, Plicity, Maybe d) -> PTerm)
-> [(Name, PTerm, Plicity, Maybe d)] -> [PTerm]
forall a b. (a -> b) -> [a] -> [b]
map (Name, PTerm, Plicity, Maybe d) -> PTerm
forall a b c d. (a, b, c, d) -> b
second [(Name, PTerm, Plicity, Maybe d)]
args)
        second :: (a, b, c, d) -> b
second (_, x :: b
x, _, _)                          = b
x


-- | Returns an NsDict of containing all known namespaces and their contents
nsDict :: IState
       -> IO NsDict
nsDict :: IState -> IO NsDict
nsDict ist :: IState
ist = (IO NsDict -> [(Name, NsInfo)] -> IO NsDict)
-> [(Name, NsInfo)] -> IO NsDict -> IO NsDict
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((IO NsDict -> (Name, NsInfo) -> IO NsDict)
-> IO NsDict -> [(Name, NsInfo)] -> IO NsDict
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl IO NsDict -> (Name, NsInfo) -> IO NsDict
addModDoc) [(Name, NsInfo)]
modDocs (IO NsDict -> IO NsDict) -> IO NsDict -> IO NsDict
forall a b. (a -> b) -> a -> b
$ (IO NsDict -> (Name, Def) -> IO NsDict)
-> IO NsDict -> [(Name, Def)] -> IO NsDict
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl IO NsDict -> (Name, Def) -> IO NsDict
forall b. IO NsDict -> (Name, b) -> IO NsDict
adder (NsDict -> IO NsDict
forall (m :: * -> *) a. Monad m => a -> m a
return NsDict
forall k a. Map k a
M.empty) [(Name, Def)]
nameDefList
  where nameDefList :: [(Name, Def)]
nameDefList    = Context -> [(Name, Def)]
ctxtAlist (Context -> [(Name, Def)]) -> Context -> [(Name, Def)]
forall a b. (a -> b) -> a -> b
$ IState -> Context
tt_ctxt IState
ist
        adder :: IO NsDict -> (Name, b) -> IO NsDict
adder m :: IO NsDict
m (n :: Name
n, _) = do NsDict
map    <- IO NsDict
m
                            Maybe (Docs' FullDocstring)
doc    <- IState -> Name -> IO (Maybe (Docs' FullDocstring))
loadDocs IState
ist Name
n
                            let access :: Accessibility
access = IState -> Name -> Accessibility
getAccess IState
ist Name
n
                                nInfo :: NsInfo
nInfo  = Maybe FullDocstring -> [NsItem] -> NsInfo
NsInfo Maybe FullDocstring
forall a. Maybe a
Nothing [(Name
n, Maybe (Docs' FullDocstring)
doc, Accessibility
access)]
                            NsDict -> IO NsDict
forall (m :: * -> *) a. Monad m => a -> m a
return (NsDict -> IO NsDict) -> NsDict -> IO NsDict
forall a b. (a -> b) -> a -> b
$ (NsInfo -> NsInfo -> NsInfo)
-> NsName -> NsInfo -> NsDict -> NsDict
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith NsInfo -> NsInfo -> NsInfo
addNameInfo (Name -> NsName
getNs Name
n) NsInfo
nInfo NsDict
map
        addNameInfo :: NsInfo -> NsInfo -> NsInfo
addNameInfo (NsInfo m :: Maybe FullDocstring
m ns :: [NsItem]
ns) (NsInfo m' :: Maybe FullDocstring
m' ns' :: [NsItem]
ns') = Maybe FullDocstring -> [NsItem] -> NsInfo
NsInfo (Maybe FullDocstring
m Maybe FullDocstring -> Maybe FullDocstring -> Maybe FullDocstring
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe FullDocstring
m') ([NsItem]
ns [NsItem] -> [NsItem] -> [NsItem]
forall a. [a] -> [a] -> [a]
++ [NsItem]
ns')
        modDocs :: [(Name, NsInfo)]
modDocs = ((Name, FullDocstring) -> (Name, NsInfo))
-> [(Name, FullDocstring)] -> [(Name, NsInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (\(mn :: Name
mn, d :: FullDocstring
d) -> (Name
mn, Maybe FullDocstring -> [NsItem] -> NsInfo
NsInfo (FullDocstring -> Maybe FullDocstring
forall a. a -> Maybe a
Just FullDocstring
d) [])) ([(Name, FullDocstring)] -> [(Name, NsInfo)])
-> [(Name, FullDocstring)] -> [(Name, NsInfo)]
forall a b. (a -> b) -> a -> b
$ Ctxt FullDocstring -> [(Name, FullDocstring)]
forall a. Ctxt a -> [(Name, a)]
toAlist (IState -> Ctxt FullDocstring
idris_moduledocs IState
ist)
        addModDoc :: IO NsDict -> (Name, NsInfo) -> IO NsDict
        addModDoc :: IO NsDict -> (Name, NsInfo) -> IO NsDict
addModDoc dict :: IO NsDict
dict (mn :: Name
mn, d :: NsInfo
d) = (NsDict -> NsDict) -> IO NsDict -> IO NsDict
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NsInfo -> NsInfo -> NsInfo)
-> NsName -> NsInfo -> NsDict -> NsDict
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith NsInfo -> NsInfo -> NsInfo
addNameInfo (Name -> NsName
getNs Name
mn) NsInfo
d) IO NsDict
dict




-- | Gets the Accessibility for a Name
getAccess :: IState        -- ^ IState containing accessibility information
          -> Name          -- ^ The Name to retrieve access for
          -> Accessibility
getAccess :: IState -> Name -> Accessibility
getAccess ist :: IState
ist n :: Name
n =
  let res :: [(Def, Accessibility)]
res = Name -> Bool -> Context -> [(Def, Accessibility)]
lookupDefAcc Name
n Bool
False (IState -> Context
tt_ctxt IState
ist)
  in case [(Def, Accessibility)]
res of
     [(_, acc :: Accessibility
acc)] -> Accessibility
acc
     _          -> Accessibility
Private

-- | Predicate saying whether a Name possibly may have docs defined
--   Without this, getDocs from Idris.Docs may fail a pattern match.
mayHaveDocs :: Name -- ^ The Name to test
            -> Bool -- ^ The result
mayHaveDocs :: Name -> Bool
mayHaveDocs (UN _)   = Bool
True
mayHaveDocs (NS n :: Name
n _) = Name -> Bool
mayHaveDocs Name
n
mayHaveDocs _        = Bool
False


-- | Retrieves the Docs for a Name
loadDocs :: IState     -- ^ IState to extract infomation from
         -> Name       -- ^ Name to load Docs for
         -> IO (Maybe Docs)
loadDocs :: IState -> Name -> IO (Maybe (Docs' FullDocstring))
loadDocs ist :: IState
ist n :: Name
n
  | Name -> Bool
mayHaveDocs Name
n = do Either Err (Docs' FullDocstring)
docs <- ExceptT Err IO (Docs' FullDocstring)
-> IO (Either Err (Docs' FullDocstring))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Err IO (Docs' FullDocstring)
 -> IO (Either Err (Docs' FullDocstring)))
-> ExceptT Err IO (Docs' FullDocstring)
-> IO (Either Err (Docs' FullDocstring))
forall a b. (a -> b) -> a -> b
$ StateT IState (ExceptT Err IO) (Docs' FullDocstring)
-> IState -> ExceptT Err IO (Docs' FullDocstring)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Name
-> HowMuchDocs
-> StateT IState (ExceptT Err IO) (Docs' FullDocstring)
getDocs Name
n HowMuchDocs
FullDocs) IState
ist
                       case Either Err (Docs' FullDocstring)
docs of Right d :: Docs' FullDocstring
d -> Maybe (Docs' FullDocstring) -> IO (Maybe (Docs' FullDocstring))
forall (m :: * -> *) a. Monad m => a -> m a
return (Docs' FullDocstring -> Maybe (Docs' FullDocstring)
forall a. a -> Maybe a
Just Docs' FullDocstring
d)
                                    Left _  -> Maybe (Docs' FullDocstring) -> IO (Maybe (Docs' FullDocstring))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Docs' FullDocstring)
forall a. Maybe a
Nothing
  | Bool
otherwise     = Maybe (Docs' FullDocstring) -> IO (Maybe (Docs' FullDocstring))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Docs' FullDocstring)
forall a. Maybe a
Nothing


-- | Extracts names referred from a type.
--   The covering of all PTerms ensures that we avoid unanticipated cases,
--   though all of them are not needed. The author just did not know which!
--   TODO: Remove unnecessary cases
extractPTermNames :: PTerm  -- ^ Where to extract names from
                  -> [Name] -- ^ Extracted names
extractPTermNames :: PTerm -> [Name]
extractPTermNames (PRef _ _ n :: Name
n)       = [Name
n]
extractPTermNames (PInferRef _ _ n :: Name
n)  = [Name
n]
extractPTermNames (PPatvar _ n :: Name
n)      = [Name
n]
extractPTermNames (PLam _ n :: Name
n _ p1 :: PTerm
p1 p2 :: PTerm
p2) = Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: (PTerm -> [Name]) -> [PTerm] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTerm -> [Name]
extract [PTerm
p1, PTerm
p2]
extractPTermNames (PPi _ n :: Name
n _ p1 :: PTerm
p1 p2 :: PTerm
p2)  = Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: (PTerm -> [Name]) -> [PTerm] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTerm -> [Name]
extract [PTerm
p1, PTerm
p2]
extractPTermNames (PLet _ _ n :: Name
n _ p1 :: PTerm
p1 p2 :: PTerm
p2 p3 :: PTerm
p3) = Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: (PTerm -> [Name]) -> [PTerm] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTerm -> [Name]
extract [PTerm
p1, PTerm
p2, PTerm
p3]
extractPTermNames (PTyped p1 :: PTerm
p1 p2 :: PTerm
p2)     = (PTerm -> [Name]) -> [PTerm] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTerm -> [Name]
extract [PTerm
p1, PTerm
p2]
extractPTermNames (PApp _ p :: PTerm
p pas :: [PArg]
pas)     = let names :: [Name]
names = (PArg -> [Name]) -> [PArg] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PArg -> [Name]
extractPArg [PArg]
pas
                                       in  (PTerm -> [Name]
extract PTerm
p) [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
names
extractPTermNames (PAppBind _ p :: PTerm
p pas :: [PArg]
pas) = let names :: [Name]
names = (PArg -> [Name]) -> [PArg] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PArg -> [Name]
extractPArg [PArg]
pas
                                       in  (PTerm -> [Name]
extract PTerm
p) [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
names
extractPTermNames (PMatchApp _ n :: Name
n)    = [Name
n]
extractPTermNames (PCase _ p :: PTerm
p ps :: [(PTerm, PTerm)]
ps)     = let (ps1 :: [PTerm]
ps1, ps2 :: [PTerm]
ps2) = [(PTerm, PTerm)] -> ([PTerm], [PTerm])
forall a b. [(a, b)] -> ([a], [b])
unzip [(PTerm, PTerm)]
ps
                                       in  (PTerm -> [Name]) -> [PTerm] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTerm -> [Name]
extract (PTerm
pPTerm -> [PTerm] -> [PTerm]
forall a. a -> [a] -> [a]
:([PTerm]
ps1 [PTerm] -> [PTerm] -> [PTerm]
forall a. [a] -> [a] -> [a]
++ [PTerm]
ps2))
extractPTermNames (PIfThenElse _ c :: PTerm
c t :: PTerm
t f :: PTerm
f) = (PTerm -> [Name]) -> [PTerm] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTerm -> [Name]
extract [PTerm
c, PTerm
t, PTerm
f]
extractPTermNames (PRewrite _ _ a :: PTerm
a b :: PTerm
b m :: Maybe PTerm
m) | Just c :: PTerm
c <- Maybe PTerm
m =
                                       (PTerm -> [Name]) -> [PTerm] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTerm -> [Name]
extract [PTerm
a, PTerm
b, PTerm
c]
extractPTermNames (PRewrite _ _ a :: PTerm
a b :: PTerm
b _) = (PTerm -> [Name]) -> [PTerm] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTerm -> [Name]
extract [PTerm
a, PTerm
b]
extractPTermNames (PPair _ _ _ p1 :: PTerm
p1 p2 :: PTerm
p2)  = (PTerm -> [Name]) -> [PTerm] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTerm -> [Name]
extract [PTerm
p1, PTerm
p2]
extractPTermNames (PDPair _ _ _ a :: PTerm
a b :: PTerm
b c :: PTerm
c) = (PTerm -> [Name]) -> [PTerm] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTerm -> [Name]
extract [PTerm
a, PTerm
b, PTerm
c]
extractPTermNames (PAlternative _ _ l :: [PTerm]
l) = (PTerm -> [Name]) -> [PTerm] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTerm -> [Name]
extract [PTerm]
l
extractPTermNames (PHidden p :: PTerm
p)        = PTerm -> [Name]
extract PTerm
p
extractPTermNames (PGoal _ p1 :: PTerm
p1 n :: Name
n p2 :: PTerm
p2)  = Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: (PTerm -> [Name]) -> [PTerm] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTerm -> [Name]
extract [PTerm
p1, PTerm
p2]
extractPTermNames (PDoBlock pdos :: [PDo]
pdos)    = (PDo -> [Name]) -> [PDo] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PDo -> [Name]
extractPDo [PDo]
pdos
extractPTermNames (PIdiom _ p :: PTerm
p)       = PTerm -> [Name]
extract PTerm
p
extractPTermNames (PMetavar _ n :: Name
n)     = [Name
n]
extractPTermNames (PProof tacts :: [PTactic]
tacts)     = (PTactic -> [Name]) -> [PTactic] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTactic -> [Name]
extractPTactic [PTactic]
tacts
extractPTermNames (PTactics tacts :: [PTactic]
tacts)   = (PTactic -> [Name]) -> [PTactic] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTactic -> [Name]
extractPTactic [PTactic]
tacts
extractPTermNames (PCoerced p :: PTerm
p)       = PTerm -> [Name]
extract PTerm
p
extractPTermNames (PDisamb _ p :: PTerm
p)      = PTerm -> [Name]
extract PTerm
p
extractPTermNames (PUnifyLog p :: PTerm
p)      = PTerm -> [Name]
extract PTerm
p
extractPTermNames (PNoImplicits p :: PTerm
p)   = PTerm -> [Name]
extract PTerm
p
extractPTermNames (PRunElab _ p :: PTerm
p _)   = PTerm -> [Name]
extract PTerm
p
extractPTermNames (PConstSugar _ tm :: PTerm
tm) = PTerm -> [Name]
extract PTerm
tm
extractPTermNames _                  = []

-- | Shorter name for extractPTermNames
extract :: PTerm  -- ^ Where to extract names from
        -> [Name] -- ^ Extracted names
extract :: PTerm -> [Name]
extract                               = PTerm -> [Name]
extractPTermNames

-- | Helper function for extractPTermNames
extractPArg :: PArg -> [Name]
extractPArg :: PArg -> [Name]
extractPArg (PImp {pname :: forall t. PArg' t -> Name
pname=Name
n, getTm :: forall t. PArg' t -> t
getTm=PTerm
p}) = Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: PTerm -> [Name]
extract PTerm
p
extractPArg (PExp {getTm :: forall t. PArg' t -> t
getTm=PTerm
p})          = PTerm -> [Name]
extract PTerm
p
extractPArg (PConstraint {getTm :: forall t. PArg' t -> t
getTm=PTerm
p})   = PTerm -> [Name]
extract PTerm
p
extractPArg (PTacImplicit {pname :: forall t. PArg' t -> Name
pname=Name
n, getScript :: forall t. PArg' t -> t
getScript=PTerm
p1, getTm :: forall t. PArg' t -> t
getTm=PTerm
p2})
                                      = Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: ((PTerm -> [Name]) -> [PTerm] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTerm -> [Name]
extract [PTerm
p1, PTerm
p2])

-- | Helper function for extractPTermNames
extractPDo :: PDo -> [Name]
extractPDo :: PDo -> [Name]
extractPDo (DoExp   _ p :: PTerm
p)         = PTerm -> [Name]
extract PTerm
p
extractPDo (DoBind  _ n :: Name
n _ p :: PTerm
p)     = Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: PTerm -> [Name]
extract PTerm
p
extractPDo (DoBindP _ p1 :: PTerm
p1 p2 :: PTerm
p2 ps :: [(PTerm, PTerm)]
ps)  = let (ps1 :: [PTerm]
ps1, ps2 :: [PTerm]
ps2) = [(PTerm, PTerm)] -> ([PTerm], [PTerm])
forall a b. [(a, b)] -> ([a], [b])
unzip [(PTerm, PTerm)]
ps
                                       ps' :: [PTerm]
ps'        = [PTerm]
ps1 [PTerm] -> [PTerm] -> [PTerm]
forall a. [a] -> [a] -> [a]
++ [PTerm]
ps2
                                   in  (PTerm -> [Name]) -> [PTerm] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTerm -> [Name]
extract (PTerm
p1 PTerm -> [PTerm] -> [PTerm]
forall a. a -> [a] -> [a]
: PTerm
p2 PTerm -> [PTerm] -> [PTerm]
forall a. a -> [a] -> [a]
: [PTerm]
ps')
extractPDo (DoLet _ _ n :: Name
n _ p1 :: PTerm
p1 p2 :: PTerm
p2) = Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: (PTerm -> [Name]) -> [PTerm] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTerm -> [Name]
extract [PTerm
p1, PTerm
p2]
extractPDo (DoLetP  _ p1 :: PTerm
p1 p2 :: PTerm
p2 ps :: [(PTerm, PTerm)]
ps)  = let (ps1 :: [PTerm]
ps1, ps2 :: [PTerm]
ps2) = [(PTerm, PTerm)] -> ([PTerm], [PTerm])
forall a b. [(a, b)] -> ([a], [b])
unzip [(PTerm, PTerm)]
ps
                                       ps' :: [PTerm]
ps'        = [PTerm]
ps1 [PTerm] -> [PTerm] -> [PTerm]
forall a. [a] -> [a] -> [a]
++ [PTerm]
ps2
                                   in  (PTerm -> [Name]) -> [PTerm] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTerm -> [Name]
extract (PTerm
p1 PTerm -> [PTerm] -> [PTerm]
forall a. a -> [a] -> [a]
: PTerm
p2 PTerm -> [PTerm] -> [PTerm]
forall a. a -> [a] -> [a]
: [PTerm]
ps')
extractPDo (DoRewrite  _ p :: PTerm
p)      = PTerm -> [Name]
extract PTerm
p

-- | Helper function for extractPTermNames
extractPTactic :: PTactic -> [Name]
extractPTactic :: PTactic -> [Name]
extractPTactic (Intro ns :: [Name]
ns)         = [Name]
ns
extractPTactic (Focus n :: Name
n)          = [Name
n]
extractPTactic (Refine n :: Name
n _)       = [Name
n]
extractPTactic (Rewrite p :: PTerm
p)        = PTerm -> [Name]
extract PTerm
p
extractPTactic (Equiv p :: PTerm
p)          = PTerm -> [Name]
extract PTerm
p
extractPTactic (MatchRefine n :: Name
n)    = [Name
n]
extractPTactic (LetTac n :: Name
n p :: PTerm
p)       = Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: PTerm -> [Name]
extract PTerm
p
extractPTactic (LetTacTy n :: Name
n p1 :: PTerm
p1 p2 :: PTerm
p2) = Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: (PTerm -> [Name]) -> [PTerm] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTerm -> [Name]
extract [PTerm
p1, PTerm
p2]
extractPTactic (Exact p :: PTerm
p)          = PTerm -> [Name]
extract PTerm
p
extractPTactic (ProofSearch _ _ _ m :: Maybe Name
m _ ns :: [Name]
ns) | Just n :: Name
n <- Maybe Name
m = Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
ns
extractPTactic (ProofSearch _ _ _ _ _ ns :: [Name]
ns) = [Name]
ns
extractPTactic (Try t1 :: PTactic
t1 t2 :: PTactic
t2)        = (PTactic -> [Name]) -> [PTactic] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTactic -> [Name]
extractPTactic [PTactic
t1, PTactic
t2]
extractPTactic (TSeq t1 :: PTactic
t1 t2 :: PTactic
t2)       = (PTactic -> [Name]) -> [PTactic] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PTactic -> [Name]
extractPTactic [PTactic
t1, PTactic
t2]
extractPTactic (ApplyTactic p :: PTerm
p)    = PTerm -> [Name]
extract PTerm
p
extractPTactic (ByReflection p :: PTerm
p)   = PTerm -> [Name]
extract PTerm
p
extractPTactic (Reflect p :: PTerm
p)        = PTerm -> [Name]
extract PTerm
p
extractPTactic (Fill p :: PTerm
p)           = PTerm -> [Name]
extract PTerm
p
extractPTactic (GoalType _ t :: PTactic
t)     = PTactic -> [Name]
extractPTactic PTactic
t
extractPTactic (TCheck p :: PTerm
p)         = PTerm -> [Name]
extract PTerm
p
extractPTactic (TEval p :: PTerm
p)          = PTerm -> [Name]
extract PTerm
p
extractPTactic _                  = []

-- ------------------------------------------------------- [ HTML Generation ]

-- | Generates the actual HTML output based on info from a NsDict
--   A merge of the new docs and any existing docs located in the output dir
--   is attempted.
--   TODO: Ensure the merge always succeeds.
--         Currently the content of 'docs/<builtins>.html' may change between
--         runs, thus not always containing all items referred from other
--         namespace .html files.
createDocs :: IState -- ^ Needed to determine the types of names
           -> NsDict   -- ^ All info from which to generate docs
           -> FilePath -- ^ The base directory to which
                       --   documentation will be written.
           -> IO (Failable ())
createDocs :: IState -> NsDict -> FilePath -> IO (Either FilePath ())
createDocs ist :: IState
ist nsd :: NsDict
nsd out :: FilePath
out =
  do Bool
new                <- Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath
out FilePath -> FilePath -> FilePath
</> "IdrisDoc")
     Set NsName
existing_nss       <- FilePath -> IO (Set NsName)
existingNamespaces FilePath
out
     let nss :: Set NsName
nss             = Set NsName -> Set NsName -> Set NsName
forall a. Ord a => Set a -> Set a -> Set a
S.union (NsDict -> Set NsName
forall k a. Map k a -> Set k
M.keysSet NsDict
nsd) Set NsName
existing_nss
     Bool
dExists            <- FilePath -> IO Bool
doesDirectoryExist FilePath
out
     if Bool
new Bool -> Bool -> Bool
&& Bool
dExists then FilePath -> IO (Either FilePath ())
err (FilePath -> IO (Either FilePath ()))
-> FilePath -> IO (Either FilePath ())
forall a b. (a -> b) -> a -> b
$ "Output directory (" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
out FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ") is" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                                  " already in use for other than IdrisDoc."
       else do
         Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
out
         (IO () -> (NsName, NsInfo) -> IO ())
-> IO () -> [(NsName, NsInfo)] -> IO ()
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl IO () -> (NsName, NsInfo) -> IO ()
forall a. IO a -> (NsName, NsInfo) -> IO ()
docGen (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (NsDict -> [(NsName, NsInfo)]
forall k a. Map k a -> [(k, a)]
M.toList NsDict
nsd)
         Set NsName -> FilePath -> IO ()
createIndex Set NsName
nss FilePath
out
         -- Create an empty IdrisDoc file to signal 'out' is used for IdrisDoc
         if Bool
new -- But only if it not already existed...
            then FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile (FilePath
out FilePath -> FilePath -> FilePath
</> "IdrisDoc") IOMode
WriteMode (((Handle -> FilePath -> IO ()) -> FilePath -> Handle -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> FilePath -> IO ()
hPutStr) "")
            else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         FilePath -> IO ()
copyDependencies FilePath
out
         Either FilePath () -> IO (Either FilePath ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath () -> IO (Either FilePath ()))
-> Either FilePath () -> IO (Either FilePath ())
forall a b. (a -> b) -> a -> b
$ () -> Either FilePath ()
forall a b. b -> Either a b
Right ()

  where docGen :: IO a -> (NsName, NsInfo) -> IO ()
docGen io :: IO a
io (n :: NsName
n, c :: NsInfo
c) = do IO a
io; IState -> NsName -> NsInfo -> FilePath -> IO ()
createNsDoc IState
ist NsName
n NsInfo
c FilePath
out


-- | (Over)writes the 'index.html' file in the given directory with
--   an (updated) index of namespaces in the documentation
createIndex :: S.Set NsName -- ^ Set of namespace names to
                            --   include in the index
            -> FilePath     -- ^ The base directory to which
                            --   documentation will be written.
            -> IO ()
createIndex :: Set NsName -> FilePath -> IO ()
createIndex nss :: Set NsName
nss out :: FilePath
out =
  do (path :: FilePath
path, h :: Handle
h) <- FilePath -> FilePath -> IO (FilePath, Handle)
openTempFileWithDefaultPermissions FilePath
out "index.html"
     Handle -> ByteString -> IO ()
BS2.hPut Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Html -> ByteString
renderHtml (Html -> ByteString) -> Html -> ByteString
forall a b. (a -> b) -> a -> b
$ Maybe NsName -> Html -> Html
wrapper Maybe NsName
forall a. Maybe a
Nothing (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
       Html -> Html
H.h1 "Namespaces"
       Html -> Html
H.ul (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "names" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
         let path :: NsName -> FilePath
path ns :: NsName
ns  = "docs" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ NsName -> FilePath -> FilePath
genRelNsPath NsName
ns "html"
             item :: NsName -> Html
item ns :: NsName
ns  = do let n :: Html
n    = FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$ NsName -> FilePath
nsName2Str NsName
ns
                               link :: AttributeValue
link = FilePath -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ NsName -> FilePath
path NsName
ns
                           Html -> Html
H.li (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
href AttributeValue
link (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "code" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
n
             sort :: [NsName] -> [NsName]
sort     = (NsName -> NsName -> Ordering) -> [NsName] -> [NsName]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (\n1 :: NsName
n1 n2 :: NsName
n2 -> NsName -> NsName
forall a. [a] -> [a]
reverse NsName
n1 NsName -> NsName -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` NsName -> NsName
forall a. [a] -> [a]
reverse NsName
n2)
         [NsName] -> (NsName -> Html) -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([NsName] -> [NsName]
sort ([NsName] -> [NsName]) -> [NsName] -> [NsName]
forall a b. (a -> b) -> a -> b
$ Set NsName -> [NsName]
forall a. Set a -> [a]
S.toList Set NsName
nss) NsName -> Html
item
     Handle -> IO ()
hClose Handle
h
     FilePath -> FilePath -> IO ()
renameFile FilePath
path (FilePath
out FilePath -> FilePath -> FilePath
</> "index.html")


-- | Generates a HTML file for a namespace and its contents.
--   The location for e.g. Prelude.Algebra is <base>/Prelude/Algebra.html
createNsDoc :: IState   -- ^ Needed to determine the types of names
            -> NsName   -- ^ The name of the namespace to
                        --   create documentation for
            -> NsInfo   -- ^ The contents of the namespace
            -> FilePath -- ^ The base directory to which
                        --   documentation will be written.
            -> IO ()
createNsDoc :: IState -> NsName -> NsInfo -> FilePath -> IO ()
createNsDoc ist :: IState
ist ns :: NsName
ns content :: NsInfo
content out :: FilePath
out =
  do let tpath :: FilePath
tpath               = FilePath
out FilePath -> FilePath -> FilePath
</> "docs" FilePath -> FilePath -> FilePath
</> (NsName -> FilePath -> FilePath
genRelNsPath NsName
ns "html")
         dir :: FilePath
dir                 = FilePath -> FilePath
takeDirectory FilePath
tpath
         file :: FilePath
file                = FilePath -> FilePath
takeFileName FilePath
tpath
         haveDocs :: (a, b, c) -> b
haveDocs (_, md :: b
md, _) = b
md
                                 -- We cannot do anything without a Doc
         content' :: [Docs' FullDocstring]
content'            = [Docs' FullDocstring] -> [Docs' FullDocstring]
forall a. [a] -> [a]
reverse ([Docs' FullDocstring] -> [Docs' FullDocstring])
-> [Docs' FullDocstring] -> [Docs' FullDocstring]
forall a b. (a -> b) -> a -> b
$ (NsItem -> Maybe (Docs' FullDocstring))
-> [NsItem] -> [Docs' FullDocstring]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe NsItem -> Maybe (Docs' FullDocstring)
forall a b c. (a, b, c) -> b
haveDocs ([NsItem] -> [Docs' FullDocstring])
-> [NsItem] -> [Docs' FullDocstring]
forall a b. (a -> b) -> a -> b
$ NsInfo -> [NsItem]
nsContents NsInfo
content
     Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dir
     (path :: FilePath
path, h :: Handle
h) <- FilePath -> FilePath -> IO (FilePath, Handle)
openTempFileWithDefaultPermissions FilePath
dir FilePath
file
     Handle -> ByteString -> IO ()
BS2.hPut Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Html -> ByteString
renderHtml (Html -> ByteString) -> Html -> ByteString
forall a b. (a -> b) -> a -> b
$ Maybe NsName -> Html -> Html
wrapper (NsName -> Maybe NsName
forall a. a -> Maybe a
Just NsName
ns) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
       Html -> Html
H.h1 (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml (NsName -> FilePath
nsName2Str NsName
ns)
       case NsInfo -> Maybe FullDocstring
nsDocstring NsInfo
content of
         Nothing -> Html
forall a. Monoid a => a
mempty
         Just docstring :: FullDocstring
docstring -> FullDocstring -> Html
Docstrings.renderHtml FullDocstring
docstring
       Html -> Html
H.dl (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "decls" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Docs' FullDocstring] -> (Docs' FullDocstring -> Html) -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Docs' FullDocstring]
content' (IState -> Docs' FullDocstring -> Html
createOtherDoc IState
ist)
     Handle -> IO ()
hClose Handle
h
     FilePath -> FilePath -> IO ()
renameFile FilePath
path FilePath
tpath


-- | Generates a relative filepath for a namespace, appending an extension
genRelNsPath :: NsName   -- ^ Namespace to generate a path for
             -> String   -- ^ Extension suffix
             -> FilePath
genRelNsPath :: NsName -> FilePath -> FilePath
genRelNsPath ns :: NsName
ns suffix :: FilePath
suffix = NsName -> FilePath
nsName2Str NsName
ns FilePath -> FilePath -> FilePath
<.> FilePath
suffix


-- | Generates a HTML type signature with proper tags
--   TODO: Turn docstrings into title attributes more robustly
genTypeHeader :: IState -- ^ Needed to determine the types of names
              -> FunDoc -- ^ Type to generate type declaration for
              -> H.Html -- ^ Resulting HTML
genTypeHeader :: IState -> FunDoc' FullDocstring -> Html
genTypeHeader ist :: IState
ist (FD n :: Name
n _ args :: [(Name, PTerm, Plicity, Maybe FullDocstring)]
args ftype :: PTerm
ftype _) = do
  Html -> Html
H.span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ (FilePath -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ "name " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Name -> FilePath
getType Name
n)
         (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
title  (FilePath -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
forall a. Show a => a -> FilePath
show Name
n)
         (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
name (Name -> FilePath) -> Name -> FilePath
forall a b. (a -> b) -> a -> b
$ Name -> Name
nsroot Name
n
  Html -> Html
H.span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "word"     (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do Html
nbsp; ":"; Html
nbsp
  Html -> Html
H.span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "signature" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ FilePath -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml FilePath
htmlSignature

  where
        htmlSignature :: FilePath
htmlSignature  = (OutputAnnotation -> FilePath -> FilePath)
-> SimpleDoc OutputAnnotation -> FilePath
forall a. (a -> FilePath -> FilePath) -> SimpleDoc a -> FilePath
displayDecorated OutputAnnotation -> FilePath -> FilePath
decorator (SimpleDoc OutputAnnotation -> FilePath)
-> SimpleDoc OutputAnnotation -> FilePath
forall a b. (a -> b) -> a -> b
$ Doc OutputAnnotation -> SimpleDoc OutputAnnotation
forall a. Doc a -> SimpleDoc a
renderCompact Doc OutputAnnotation
signature
        signature :: Doc OutputAnnotation
signature      = PPOption
-> [(Name, Bool)]
-> [Name]
-> [FixDecl]
-> PTerm
-> Doc OutputAnnotation
pprintPTerm PPOption
defaultPPOption [] [Name]
names (IState -> [FixDecl]
idris_infixes IState
ist) PTerm
ftype
        names :: [Name]
names          = [ Name
n | (n :: Name
n@(UN n' :: Text
n'), _, _, _) <- [(Name, PTerm, Plicity, Maybe FullDocstring)]
args,
                           Bool -> Bool
not (Text -> Text -> Bool
T.isPrefixOf (FilePath -> Text
txt "__") Text
n') ]

        decorator :: OutputAnnotation -> FilePath -> FilePath
decorator (AnnConst c :: Const
c) str :: FilePath
str | Const -> Bool
constIsType Const
c = FilePath -> FilePath -> FilePath -> FilePath
htmlSpan FilePath
str "type" FilePath
str
                                   | Bool
otherwise     = FilePath -> FilePath -> FilePath -> FilePath
htmlSpan FilePath
str "data" FilePath
str
        decorator (AnnData _ _) str :: FilePath
str = FilePath -> FilePath -> FilePath -> FilePath
htmlSpan FilePath
str "data"    FilePath
str
        decorator (AnnType _ _)   str :: FilePath
str = FilePath -> FilePath -> FilePath -> FilePath
htmlSpan FilePath
str "type"    FilePath
str
        decorator AnnKeyword    str :: FilePath
str = FilePath -> FilePath -> FilePath -> FilePath
htmlSpan ""  "keyword" FilePath
str
        decorator (AnnBoundName n :: Name
n i :: Bool
i) str :: FilePath
str | Just t :: FilePath
t <- Name -> Map Name FilePath -> Maybe FilePath
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n Map Name FilePath
docs =
          let cs :: FilePath
cs = (if Bool
i then "implicit " else "") FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "documented boundvar"
          in  FilePath -> FilePath -> FilePath -> FilePath
htmlSpan FilePath
t FilePath
cs FilePath
str
        decorator (AnnBoundName _ i :: Bool
i) str :: FilePath
str =
          let cs :: FilePath
cs = (if Bool
i then "implicit " else "") FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "boundvar"
          in  FilePath -> FilePath -> FilePath -> FilePath
htmlSpan "" FilePath
cs FilePath
str
        decorator (AnnName n :: Name
n _ _ _) str :: FilePath
str
          | Name -> Bool
filterName Name
n = FilePath -> FilePath -> FilePath -> FilePath -> FilePath
htmlLink (Name -> FilePath
forall a. Show a => a -> FilePath
show Name
n) (Name -> FilePath
getType Name
n) (Name -> FilePath
link Name
n) FilePath
str
          | Bool
otherwise    = FilePath -> FilePath -> FilePath -> FilePath
htmlSpan ""       (Name -> FilePath
getType Name
n)          FilePath
str
        decorator (AnnTextFmt BoldText)      str :: FilePath
str = "<b>" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
str FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "</b>"
        decorator (AnnTextFmt UnderlineText) str :: FilePath
str = "<u>" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
str FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "</u>"
        decorator (AnnTextFmt ItalicText)    str :: FilePath
str = "<i>" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
str FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "</i>"
        decorator _ str :: FilePath
str = FilePath
str

        htmlSpan :: String -> String -> String -> String
        htmlSpan :: FilePath -> FilePath -> FilePath -> FilePath
htmlSpan t :: FilePath
t cs :: FilePath
cs str :: FilePath
str = do
          Html -> FilePath
R.renderHtml (Html -> FilePath) -> Html -> FilePath
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ (FilePath -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue FilePath
cs)
                                (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
title (FilePath -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue FilePath
t)
                                (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml FilePath
str
        htmlLink :: String -> String -> String -> String -> String
        htmlLink :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath
htmlLink t :: FilePath
t cs :: FilePath
cs a :: FilePath
a str :: FilePath
str = do
          Html -> FilePath
R.renderHtml (Html -> FilePath) -> Html -> FilePath
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ (FilePath -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue FilePath
cs)
                       (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
title (FilePath -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue FilePath
t) (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
href (FilePath -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue FilePath
a)
                       (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml FilePath
str

        docs :: Map Name FilePath
docs           = [(Name, FilePath)] -> Map Name FilePath
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, FilePath)] -> Map Name FilePath)
-> [(Name, FilePath)] -> Map Name FilePath
forall a b. (a -> b) -> a -> b
$ ((Name, PTerm, Plicity, Maybe FullDocstring)
 -> Maybe (Name, FilePath))
-> [(Name, PTerm, Plicity, Maybe FullDocstring)]
-> [(Name, FilePath)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Name, PTerm, Plicity, Maybe FullDocstring)
-> Maybe (Name, FilePath)
forall a b c. (a, b, c, Maybe FullDocstring) -> Maybe (a, FilePath)
docExtractor [(Name, PTerm, Plicity, Maybe FullDocstring)]
args
        docExtractor :: (a, b, c, Maybe FullDocstring) -> Maybe (a, FilePath)
docExtractor (_, _, _, Nothing) = Maybe (a, FilePath)
forall a. Maybe a
Nothing
        docExtractor (n :: a
n, _, _, Just d :: FullDocstring
d)  = (a, FilePath) -> Maybe (a, FilePath)
forall a. a -> Maybe a
Just (a
n, FullDocstring -> FilePath
doc2Str FullDocstring
d)
                         -- TODO: Remove <p> tags more robustly
        doc2Str :: FullDocstring -> FilePath
doc2Str d :: FullDocstring
d      = let dirty :: FilePath
dirty = Html -> FilePath
renderMarkup (Html -> FilePath) -> Html -> FilePath
forall a b. (a -> b) -> a -> b
$ Html -> Html
forall a. MarkupM a -> MarkupM a
contents (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ FullDocstring -> Html
Docstrings.renderHtml FullDocstring
d
                         in  Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
dirty Int -> Int -> Int
forall a. Num a => a -> a -> a
- 8) (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop 3 FilePath
dirty

        name :: Name -> FilePath
name (NS n :: Name
n ns :: NsName
ns) = Name -> FilePath
forall a. Show a => a -> FilePath
show (Name -> NsName -> Name
NS (FilePath -> Name
sUN (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
name Name
n) NsName
ns)
        name n :: Name
n         = let n' :: FilePath
n' = Name -> FilePath
forall a. Show a => a -> FilePath
show Name
n
                         in  if (FilePath -> Char
forall a. [a] -> a
head FilePath
n') Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
opChars
                                then '('Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:(FilePath
n' FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ")")
                                else FilePath
n'

        link :: Name -> FilePath
link n :: Name
n         = let path :: FilePath
path = NsName -> FilePath -> FilePath
genRelNsPath (Name -> NsName
getNs Name
n) "html"
                         in  FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "#" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Name -> FilePath
forall a. Show a => a -> FilePath
show Name
n)

        getType :: Name -> String
        getType :: Name -> FilePath
getType n :: Name
n      = let ctxt :: Context
ctxt = IState -> Context
tt_ctxt IState
ist
                         in  case () of
                               _ | Name -> Context -> Bool
isDConName Name
n Context
ctxt -> "constructor"
                               _ | Name -> Context -> Bool
isFnName   Name
n Context
ctxt -> "function"
                               _ | Name -> Context -> Bool
isTConName Name
n Context
ctxt -> "type"
                               _ | Bool
otherwise         -> ""

-- | Generates HTML documentation for a function.
createFunDoc :: IState -- ^ Needed to determine the types of names
             -> FunDoc -- ^ Function to generate block for
             -> H.Html -- ^ Resulting HTML
createFunDoc :: IState -> FunDoc' FullDocstring -> Html
createFunDoc ist :: IState
ist fd :: FunDoc' FullDocstring
fd@(FD name :: Name
name docstring :: FullDocstring
docstring args :: [(Name, PTerm, Plicity, Maybe FullDocstring)]
args ftype :: PTerm
ftype fixity :: Maybe Fixity
fixity) = do
  Html -> Html
H.dt (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! (AttributeValue -> Attribute
A.id (AttributeValue -> Attribute) -> AttributeValue -> Attribute
forall a b. (a -> b) -> a -> b
$ FilePath -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
forall a. Show a => a -> FilePath
show Name
name) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ IState -> FunDoc' FullDocstring -> Html
genTypeHeader IState
ist FunDoc' FullDocstring
fd
  Html -> Html
H.dd (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    (if FullDocstring -> Bool
forall a. Docstring a -> Bool
nullDocstring FullDocstring
docstring then Html
forall a. Monoid a => a
mempty else FullDocstring -> Html
Docstrings.renderHtml FullDocstring
docstring)
    let args' :: [(Name, PTerm, Plicity, Maybe FullDocstring)]
args'             = ((Name, PTerm, Plicity, Maybe FullDocstring) -> Bool)
-> [(Name, PTerm, Plicity, Maybe FullDocstring)]
-> [(Name, PTerm, Plicity, Maybe FullDocstring)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(_, _, _, d :: Maybe FullDocstring
d) -> Maybe FullDocstring -> Bool
forall a. Maybe a -> Bool
isJust Maybe FullDocstring
d) [(Name, PTerm, Plicity, Maybe FullDocstring)]
args
    if (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Name, PTerm, Plicity, Maybe FullDocstring)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, PTerm, Plicity, Maybe FullDocstring)]
args') Bool -> Bool -> Bool
|| (Maybe Fixity -> Bool
forall a. Maybe a -> Bool
isJust Maybe Fixity
fixity)
       then Html -> Html
H.dl (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
         if (Maybe Fixity -> Bool
forall a. Maybe a -> Bool
isJust Maybe Fixity
fixity) then do
             Html -> Html
H.dt (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "fixity" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ "Fixity"
             let f :: Fixity
f = Maybe Fixity -> Fixity
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Fixity
fixity
             Html -> Html
H.dd (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "fixity" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
title (FilePath -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Fixity -> FilePath
forall a. Show a => a -> FilePath
show Fixity
f) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Fixity -> Html
genFix Fixity
f
           else Html
forall a. Monoid a => a
mempty
         [(Name, PTerm, Plicity, Maybe FullDocstring)]
-> ((Name, PTerm, Plicity, Maybe FullDocstring) -> Html) -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Name, PTerm, Plicity, Maybe FullDocstring)]
args' (Name, PTerm, Plicity, Maybe FullDocstring) -> Html
forall a b c. Show a => (a, b, c, Maybe FullDocstring) -> Html
genArg
       else Html
forall a. Monoid a => a
mempty

  where genFix :: Fixity -> Html
genFix (Infixl {prec :: Fixity -> Int
prec=Int
p})  =
          FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$ "Left associative, precedence " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
p
        genFix (Infixr {prec :: Fixity -> Int
prec=Int
p})  =
          FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$ "Left associative, precedence " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
p
        genFix (InfixN {prec :: Fixity -> Int
prec=Int
p})  =
          FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$ "Non-associative, precedence " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
p
        genFix (PrefixN {prec :: Fixity -> Int
prec=Int
p}) =
          FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$ "Prefix, precedence " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
p
        genArg :: (a, b, c, Maybe FullDocstring) -> Html
genArg (_, _, _, Nothing)           = Html
forall a. Monoid a => a
mempty
        genArg (name :: a
name, _, _, Just docstring :: FullDocstring
docstring) = do
          Html -> Html
H.dt (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$ a -> FilePath
forall a. Show a => a -> FilePath
show a
name
          Html -> Html
H.dd (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ FullDocstring -> Html
Docstrings.renderHtml FullDocstring
docstring


-- | Generates HTML documentation for any Docs type
--   TODO: Generate actual signatures for interfaces
createOtherDoc :: IState -- ^ Needed to determine the types of names
               -> Docs   -- ^ Namespace item to generate HTML block for
               -> H.Html -- ^ Resulting HTML
createOtherDoc :: IState -> Docs' FullDocstring -> Html
createOtherDoc ist :: IState
ist (FunDoc fd :: FunDoc' FullDocstring
fd)                = IState -> FunDoc' FullDocstring -> Html
createFunDoc IState
ist FunDoc' FullDocstring
fd

createOtherDoc ist :: IState
ist (InterfaceDoc n :: Name
n docstring :: FullDocstring
docstring fds :: [FunDoc' FullDocstring]
fds _ _ _ _ _ c :: Maybe (FunDoc' FullDocstring)
c) = do
  Html -> Html
H.dt (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! (AttributeValue -> Attribute
A.id (AttributeValue -> Attribute) -> AttributeValue -> Attribute
forall a b. (a -> b) -> a -> b
$ FilePath -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
forall a. Show a => a -> FilePath
show Name
n) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> Html
H.span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "word" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do "interface"; Html
nbsp
    Html -> Html
H.span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "name type"
           (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
title  (FilePath -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
forall a. Show a => a -> FilePath
show Name
n)
           (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
name (Name -> FilePath) -> Name -> FilePath
forall a b. (a -> b) -> a -> b
$ Name -> Name
nsroot Name
n
    Html -> Html
H.span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "signature" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
nbsp
  Html -> Html
H.dd (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    (if FullDocstring -> Bool
forall a. Docstring a -> Bool
nullDocstring FullDocstring
docstring then Html
forall a. Monoid a => a
mempty else FullDocstring -> Html
Docstrings.renderHtml FullDocstring
docstring)
    Html -> Html
H.dl (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "decls" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ ([FunDoc' FullDocstring] -> (FunDoc' FullDocstring -> Html) -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Maybe (FunDoc' FullDocstring) -> [FunDoc' FullDocstring]
forall a. Maybe a -> [a]
maybeToList Maybe (FunDoc' FullDocstring)
c [FunDoc' FullDocstring]
-> [FunDoc' FullDocstring] -> [FunDoc' FullDocstring]
forall a. [a] -> [a] -> [a]
++ [FunDoc' FullDocstring]
fds) (IState -> FunDoc' FullDocstring -> Html
createFunDoc IState
ist))

  where name :: Name -> FilePath
name (NS n :: Name
n ns :: NsName
ns) = Name -> FilePath
forall a. Show a => a -> FilePath
show (Name -> NsName -> Name
NS (FilePath -> Name
sUN (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
name Name
n) NsName
ns)
        name n :: Name
n         = let n' :: FilePath
n' = Name -> FilePath
forall a. Show a => a -> FilePath
show Name
n
                         in  if (FilePath -> Char
forall a. [a] -> a
head FilePath
n') Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
opChars
                                then '('Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:(FilePath
n' FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ")")
                                else FilePath
n'

createOtherDoc ist :: IState
ist (RecordDoc n :: Name
n doc :: FullDocstring
doc ctor :: FunDoc' FullDocstring
ctor projs :: [FunDoc' FullDocstring]
projs params :: [(Name, PTerm, Maybe FullDocstring)]
params) = do
  Html -> Html
H.dt (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! (AttributeValue -> Attribute
A.id (AttributeValue -> Attribute) -> AttributeValue -> Attribute
forall a b. (a -> b) -> a -> b
$ FilePath -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
forall a. Show a => a -> FilePath
show Name
n) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> Html
H.span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "word" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do "record"; Html
nbsp
    Html -> Html
H.span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "name type"
           (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
title (FilePath -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
forall a. Show a => a -> FilePath
show Name
n)
           (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
name (Name -> FilePath) -> Name -> FilePath
forall a b. (a -> b) -> a -> b
$ Name -> Name
nsroot Name
n
    Html -> Html
H.span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "type" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do Html
nbsp ; Html
prettyParameters
  Html -> Html
H.dd (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    (if FullDocstring -> Bool
forall a. Docstring a -> Bool
nullDocstring FullDocstring
doc then Html
forall a. Monoid a => a
mempty else FullDocstring -> Html
Docstrings.renderHtml FullDocstring
doc)
    if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Name, PTerm, Maybe FullDocstring)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, PTerm, Maybe FullDocstring)]
params
       then Html -> Html
H.dl (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [(Name, PTerm, Maybe FullDocstring)]
-> ((Name, PTerm, Maybe FullDocstring) -> Html) -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Name, PTerm, Maybe FullDocstring)]
params (Name, PTerm, Maybe FullDocstring) -> Html
forall b. (Name, b, Maybe FullDocstring) -> Html
genParam
       else Html
forall a. Monoid a => a
mempty
    Html -> Html
H.dl (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "decls" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ IState -> FunDoc' FullDocstring -> Html
createFunDoc IState
ist FunDoc' FullDocstring
ctor
    Html -> Html
H.dl (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "decls" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [FunDoc' FullDocstring] -> (FunDoc' FullDocstring -> Html) -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FunDoc' FullDocstring]
projs (IState -> FunDoc' FullDocstring -> Html
createFunDoc IState
ist)
  where name :: Name -> FilePath
name (NS n :: Name
n ns :: NsName
ns) = Name -> FilePath
forall a. Show a => a -> FilePath
show (Name -> NsName -> Name
NS (FilePath -> Name
sUN (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
name Name
n) NsName
ns)
        name n :: Name
n         = let n' :: FilePath
n' = Name -> FilePath
forall a. Show a => a -> FilePath
show Name
n
                         in if (FilePath -> Char
forall a. [a] -> a
head FilePath
n') Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
opChars
                               then '('Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:(FilePath
n' FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ")")
                               else FilePath
n'

        genParam :: (Name, b, Maybe FullDocstring) -> Html
genParam (name :: Name
name, pt :: b
pt, docstring :: Maybe FullDocstring
docstring) = do
          Html -> Html
H.dt (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
forall a. Show a => a -> FilePath
show (Name -> Name
nsroot Name
name)
          Html -> Html
H.dd (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> (FullDocstring -> Html) -> Maybe FullDocstring -> Html
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Html
nbsp FullDocstring -> Html
Docstrings.renderHtml Maybe FullDocstring
docstring

        prettyParameters :: Html
prettyParameters = FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords [Name -> FilePath
forall a. Show a => a -> FilePath
show (Name -> FilePath) -> Name -> FilePath
forall a b. (a -> b) -> a -> b
$ Name -> Name
nsroot Name
n | (n :: Name
n,_,_) <- [(Name, PTerm, Maybe FullDocstring)]
params]

createOtherDoc ist :: IState
ist (DataDoc fd :: FunDoc' FullDocstring
fd@(FD n :: Name
n docstring :: FullDocstring
docstring args :: [(Name, PTerm, Plicity, Maybe FullDocstring)]
args _ _) fds :: [FunDoc' FullDocstring]
fds) = do
  Html -> Html
H.dt (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! (AttributeValue -> Attribute
A.id (AttributeValue -> Attribute) -> AttributeValue -> Attribute
forall a b. (a -> b) -> a -> b
$ FilePath -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
forall a. Show a => a -> FilePath
show Name
n) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> Html
H.span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "word" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do "data"; Html
nbsp
    IState -> FunDoc' FullDocstring -> Html
genTypeHeader IState
ist FunDoc' FullDocstring
fd
  Html -> Html
H.dd (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    (if FullDocstring -> Bool
forall a. Docstring a -> Bool
nullDocstring FullDocstring
docstring then Html
forall a. Monoid a => a
mempty else FullDocstring -> Html
Docstrings.renderHtml FullDocstring
docstring)
    let args' :: [(Name, PTerm, Plicity, Maybe FullDocstring)]
args' = ((Name, PTerm, Plicity, Maybe FullDocstring) -> Bool)
-> [(Name, PTerm, Plicity, Maybe FullDocstring)]
-> [(Name, PTerm, Plicity, Maybe FullDocstring)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(_, _, _, d :: Maybe FullDocstring
d) -> Maybe FullDocstring -> Bool
forall a. Maybe a -> Bool
isJust Maybe FullDocstring
d) [(Name, PTerm, Plicity, Maybe FullDocstring)]
args
    if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Name, PTerm, Plicity, Maybe FullDocstring)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, PTerm, Plicity, Maybe FullDocstring)]
args'
       then Html -> Html
H.dl (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [(Name, PTerm, Plicity, Maybe FullDocstring)]
-> ((Name, PTerm, Plicity, Maybe FullDocstring) -> Html) -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Name, PTerm, Plicity, Maybe FullDocstring)]
args' (Name, PTerm, Plicity, Maybe FullDocstring) -> Html
forall a b c. Show a => (a, b, c, Maybe FullDocstring) -> Html
genArg
       else Html
forall a. Monoid a => a
mempty
    Html -> Html
H.dl (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "decls" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [FunDoc' FullDocstring] -> (FunDoc' FullDocstring -> Html) -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FunDoc' FullDocstring]
fds (IState -> FunDoc' FullDocstring -> Html
createFunDoc IState
ist)

  where genArg :: (a, b, c, Maybe FullDocstring) -> Html
genArg (_, _, _, Nothing)           = Html
forall a. Monoid a => a
mempty
        genArg (name :: a
name, _, _, Just docstring :: FullDocstring
docstring) = do
          Html -> Html
H.dt (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$ a -> FilePath
forall a. Show a => a -> FilePath
show a
name
          Html -> Html
H.dd (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ FullDocstring -> Html
Docstrings.renderHtml FullDocstring
docstring

createOtherDoc ist :: IState
ist (NamedImplementationDoc _ fd :: FunDoc' FullDocstring
fd) = IState -> FunDoc' FullDocstring -> Html
createFunDoc IState
ist FunDoc' FullDocstring
fd

createOtherDoc ist :: IState
ist (ModDoc _  docstring :: FullDocstring
docstring) = do
  FullDocstring -> Html
Docstrings.renderHtml FullDocstring
docstring

-- | Generates everything but the actual content of the page
wrapper :: Maybe NsName -- ^ Namespace name, unless it is the index
        -> H.Html         -- ^ Inner HTML
        -> H.Html
wrapper :: Maybe NsName -> Html -> Html
wrapper ns :: Maybe NsName
ns inner :: Html
inner =
  let (index :: Bool
index, str :: FilePath
str) = Maybe NsName -> (Bool, FilePath)
extract Maybe NsName
ns
      base :: FilePath
base       = if Bool
index then "" else "../"
      styles :: FilePath
styles     = FilePath
base FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "styles.css" :: String
      indexPage :: FilePath
indexPage  = FilePath
base FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "index.html" :: String
  in  Html -> Html
H.docTypeHtml (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> Html
H.head (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html
H.meta Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
charset "utf-8"
      Html
H.meta Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
name "viewport" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
content "width=device-width, initial-scale=1, shrink-to-fit=no"
      Html -> Html
H.title (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        "IdrisDoc"
        if Bool
index then " Index" else do
          ": "
          FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml FilePath
str
      Html
H.link Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
type_ "text/css" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
rel "stylesheet"
             Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
href (FilePath -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue FilePath
styles)
    Html -> Html
H.body (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ (if Bool
index then "index" else "namespace") (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "wrapper" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
H.header (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
          Html -> Html
H.strong "IdrisDoc"
          if Bool
index then Html
forall a. Monoid a => a
mempty else do
            ": "
            FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml FilePath
str
          Html -> Html
H.nav (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
href (FilePath -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue FilePath
indexPage) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ "Index"
        Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ "container" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
inner
      Html -> Html
H.footer (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        "Produced by IdrisDoc version "
        FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml FilePath
version

  where extract :: Maybe NsName -> (Bool, FilePath)
extract (Just ns :: NsName
ns) = (Bool
False, NsName -> FilePath
nsName2Str NsName
ns)
        extract _         = (Bool
True,  "")


-- | Non-break space character
nbsp :: H.Html
nbsp :: Html
nbsp = FilePath -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml ("&nbsp;" :: String)


-- | Returns a list of namespaces already documented in a IdrisDoc directory
existingNamespaces :: FilePath -- ^ The base directory containing the
                               --   'docs' directory with existing
                               --   namespace pages
                   -> IO (S.Set NsName)
existingNamespaces :: FilePath -> IO (Set NsName)
existingNamespaces out :: FilePath
out = do
  let docs :: FilePath
docs     = FilePath
out FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "docs"
      str2Ns :: FilePath -> NsName
str2Ns s :: FilePath
s | FilePath
s FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
rootNsStr = []
      str2Ns s :: FilePath
s = NsName -> NsName
forall a. [a] -> [a]
reverse (NsName -> NsName) -> NsName -> NsName
forall a b. (a -> b) -> a -> b
$ Text -> Text -> NsName
T.splitOn (Char -> Text
T.singleton '.') (FilePath -> Text
txt FilePath
s)
      toNs :: FilePath -> IO (Maybe NsName)
toNs  fp :: FilePath
fp = do Bool
isFile    <- FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath
docs FilePath -> FilePath -> FilePath
</> FilePath
fp
                    let isHtml :: Bool
isHtml = ".html" FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> FilePath
takeExtension FilePath
fp
                        name :: FilePath
name   = FilePath -> FilePath
dropExtension FilePath
fp
                        ns :: NsName
ns     = FilePath -> NsName
str2Ns FilePath
name
                    Maybe NsName -> IO (Maybe NsName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe NsName -> IO (Maybe NsName))
-> Maybe NsName -> IO (Maybe NsName)
forall a b. (a -> b) -> a -> b
$ if Bool
isFile Bool -> Bool -> Bool
&& Bool
isHtml then NsName -> Maybe NsName
forall a. a -> Maybe a
Just NsName
ns else Maybe NsName
forall a. Maybe a
Nothing
  Bool
docsExists  <- FilePath -> IO Bool
doesDirectoryExist FilePath
docs
  if Bool -> Bool
not Bool
docsExists
     then    Set NsName -> IO (Set NsName)
forall (m :: * -> *) a. Monad m => a -> m a
return Set NsName
forall a. Set a
S.empty
     else do [FilePath]
contents    <- FilePath -> IO [FilePath]
getDirectoryContents FilePath
docs
             [NsName]
namespaces  <- [Maybe NsName] -> [NsName]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe NsName] -> [NsName]) -> IO [Maybe NsName] -> IO [NsName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ([IO (Maybe NsName)] -> IO [Maybe NsName]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([IO (Maybe NsName)] -> IO [Maybe NsName])
-> [IO (Maybe NsName)] -> IO [Maybe NsName]
forall a b. (a -> b) -> a -> b
$ (FilePath -> IO (Maybe NsName))
-> [FilePath] -> [IO (Maybe NsName)]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> IO (Maybe NsName)
toNs [FilePath]
contents)
             Set NsName -> IO (Set NsName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set NsName -> IO (Set NsName)) -> Set NsName -> IO (Set NsName)
forall a b. (a -> b) -> a -> b
$ [NsName] -> Set NsName
forall a. Ord a => [a] -> Set a
S.fromList [NsName]
namespaces


-- | Copies IdrisDoc dependencies such as stylesheets to a directory
copyDependencies :: FilePath -- ^ The base directory to which
                             --   dependencies should be written
                 -> IO ()
copyDependencies :: FilePath -> IO ()
copyDependencies dir :: FilePath
dir =
  do FilePath
styles <- FilePath -> IO FilePath
getIdrisDataFileByName (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ "idrisdoc" FilePath -> FilePath -> FilePath
</> "styles.css"
     FilePath -> FilePath -> IO ()
copyFile FilePath
styles (FilePath
dir FilePath -> FilePath -> FilePath
</> "styles.css")