-- | The core logic of @futhark doc@.
module Futhark.Doc.Generator (renderFiles) where

import CMarkGFM qualified as GFM
import Control.Arrow ((***))
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Writer (Writer, WriterT, runWriter, runWriterT, tell)
import Data.Bifunctor (second)
import Data.Char (isAlpha, isSpace, toUpper)
import Data.List (find, groupBy, inits, intersperse, isPrefixOf, partition, sort, sortOn, tails)
import Data.Map qualified as M
import Data.Maybe
import Data.Set qualified as S
import Data.String (fromString)
import Data.Text qualified as T
import Data.Version
import Futhark.Util.Html (headHtml, relativise)
import Futhark.Util.Pretty (Doc, docText, pretty)
import Futhark.Version
import Language.Futhark
import Language.Futhark.Semantic
import Language.Futhark.Warnings
import System.FilePath (makeRelative, (-<.>), (</>))
import Text.Blaze.Html5 (AttributeValue, Html, toHtml, (!))
import Text.Blaze.Html5 qualified as H
import Text.Blaze.Html5.Attributes qualified as A
import Prelude hiding (abs, mod)

docToHtml :: Doc a -> Html
docToHtml :: forall a. Doc a -> Html
docToHtml = Text -> Html
forall a. ToMarkup a => a -> Html
toHtml (Text -> Html) -> (Doc a -> Text) -> Doc a -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc a -> Text
forall a. Doc a -> Text
docText

primTypeHtml :: PrimType -> Html
primTypeHtml :: PrimType -> Html
primTypeHtml = Doc (ZonkAny 0) -> Html
forall a. Doc a -> Html
docToHtml (Doc (ZonkAny 0) -> Html)
-> (PrimType -> Doc (ZonkAny 0)) -> PrimType -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimType -> Doc (ZonkAny 0)
forall a ann. Pretty a => a -> Doc ann
forall ann. PrimType -> Doc ann
pretty

prettyMode :: Freshness -> Html
prettyMode :: Freshness -> Html
prettyMode = Doc (ZonkAny 1) -> Html
forall a. Doc a -> Html
docToHtml (Doc (ZonkAny 1) -> Html)
-> (Freshness -> Doc (ZonkAny 1)) -> Freshness -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Freshness -> Doc (ZonkAny 1)
forall a ann. Pretty a => a -> Doc ann
forall ann. Freshness -> Doc ann
pretty

renderName :: Name -> Html
renderName :: Name -> Html
renderName Name
name = Doc (ZonkAny 2) -> Html
forall a. Doc a -> Html
docToHtml (Name -> Doc (ZonkAny 2)
forall a ann. Pretty a => a -> Doc ann
forall ann. Name -> Doc ann
pretty Name
name)

joinBy :: Html -> [Html] -> Html
joinBy :: Html -> [Html] -> Html
joinBy Html
_ [] = Html
forall a. Monoid a => a
mempty
joinBy Html
_ [Html
x] = Html
x
joinBy Html
sep (Html
x : [Html]
xs) = Html
x Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> (Html -> Html) -> [Html] -> Html
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Html
sep Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<>) [Html]
xs

commas :: [Html] -> Html
commas :: [Html] -> Html
commas = Html -> [Html] -> Html
joinBy Html
", "

parens :: Html -> Html
parens :: Html -> Html
parens Html
x = Html
"(" Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
x Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
")"

braces :: Html -> Html
braces :: Html -> Html
braces Html
x = Html
"{" Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
x Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
"}"

brackets :: Html -> Html
brackets :: Html -> Html
brackets Html
x = Html
"[" Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
x Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
"]"

pipes :: [Html] -> Html
pipes :: [Html] -> Html
pipes = Html -> [Html] -> Html
joinBy Html
" | "

-- | A set of names that we should not generate links to, because they
-- are uninteresting.  These are for example type parameters.
type NoLink = S.Set VName

-- | A mapping from unique names to the file in which they exist, and
-- the anchor (not necessarily globally unique) for linking to that
-- name.
type FileMap = M.Map VName (FilePath, String)

-- | Return the base 'Name' converted to a string.
baseString :: VName -> String
baseString :: VName -> FilePath
baseString = Name -> FilePath
nameToString (Name -> FilePath) -> (VName -> Name) -> VName -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> Name
baseName

vnameToFileMap :: Imports -> FileMap
vnameToFileMap :: Imports -> FileMap
vnameToFileMap = [FileMap] -> FileMap
forall a. Monoid a => [a] -> a
mconcat ([FileMap] -> FileMap)
-> (Imports -> [FileMap]) -> Imports -> FileMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ImportName, FileModule) -> FileMap) -> Imports -> [FileMap]
forall a b. (a -> b) -> [a] -> [b]
map (ImportName, FileModule) -> FileMap
forFile
  where
    forFile :: (ImportName, FileModule) -> FileMap
forFile (ImportName
file, FileModule TySet
_ Env
file_env Prog
_prog Env
_) =
      FilePath -> Env -> FileMap
forEnv FilePath
"" Env
file_env
      where
        file' :: FilePath
file' = FilePath -> FilePath -> FilePath
makeRelative FilePath
"/" (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ ImportName -> FilePath
includeToFilePath ImportName
file
        vname :: FilePath -> Namespace -> QualName VName -> FileMap
vname FilePath
prefix Namespace
ns QualName VName
v =
          VName -> (FilePath, FilePath) -> FileMap
forall k a. k -> a -> Map k a
M.singleton (QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
v) (FilePath
file', Namespace -> FilePath -> FilePath
forall {a}. (Semigroup a, IsString a) => Namespace -> a -> a
canon Namespace
ns (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
prefix FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> VName -> FilePath
baseString (QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
v))
        vname' :: FilePath -> ((Namespace, b), QualName VName) -> FileMap
vname' FilePath
prefix ((Namespace
ns, b
_), QualName VName
v) = FilePath -> Namespace -> QualName VName -> FileMap
vname FilePath
prefix Namespace
ns QualName VName
v
        canon :: Namespace -> a -> a
canon Namespace
Term a
s = a
"term:" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
s
        canon Namespace
Type a
s = a
"type:" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
s
        canon Namespace
Signature a
s = a
"modtype:" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
s

        forEnv :: FilePath -> Env -> FileMap
forEnv FilePath
prefix Env
env =
          [FileMap] -> FileMap
forall a. Monoid a => [a] -> a
mconcat (((VName, TypeBinding) -> FileMap)
-> [(VName, TypeBinding)] -> [FileMap]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> (VName, TypeBinding) -> FileMap
forall {b}. FilePath -> (VName, b) -> FileMap
forType FilePath
prefix) ([(VName, TypeBinding)] -> [FileMap])
-> [(VName, TypeBinding)] -> [FileMap]
forall a b. (a -> b) -> a -> b
$ Map VName TypeBinding -> [(VName, TypeBinding)]
forall k a. Map k a -> [(k, a)]
M.toList (Map VName TypeBinding -> [(VName, TypeBinding)])
-> Map VName TypeBinding -> [(VName, TypeBinding)]
forall a b. (a -> b) -> a -> b
$ Env -> Map VName TypeBinding
envTypeTable Env
env)
            FileMap -> FileMap -> FileMap
forall a. Semigroup a => a -> a -> a
<> [FileMap] -> FileMap
forall a. Monoid a => [a] -> a
mconcat (((VName, Mod) -> FileMap) -> [(VName, Mod)] -> [FileMap]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> (VName, Mod) -> FileMap
forMod FilePath
prefix) ([(VName, Mod)] -> [FileMap]) -> [(VName, Mod)] -> [FileMap]
forall a b. (a -> b) -> a -> b
$ Map VName Mod -> [(VName, Mod)]
forall k a. Map k a -> [(k, a)]
M.toList (Map VName Mod -> [(VName, Mod)])
-> Map VName Mod -> [(VName, Mod)]
forall a b. (a -> b) -> a -> b
$ Env -> Map VName Mod
envModTable Env
env)
            FileMap -> FileMap -> FileMap
forall a. Semigroup a => a -> a -> a
<> [FileMap] -> FileMap
forall a. Monoid a => [a] -> a
mconcat (((VName, MTy) -> FileMap) -> [(VName, MTy)] -> [FileMap]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> (VName, MTy) -> FileMap
forMty FilePath
prefix) ([(VName, MTy)] -> [FileMap]) -> [(VName, MTy)] -> [FileMap]
forall a b. (a -> b) -> a -> b
$ Map VName MTy -> [(VName, MTy)]
forall k a. Map k a -> [(k, a)]
M.toList (Map VName MTy -> [(VName, MTy)])
-> Map VName MTy -> [(VName, MTy)]
forall a b. (a -> b) -> a -> b
$ Env -> Map VName MTy
envModTypeTable Env
env)
            FileMap -> FileMap -> FileMap
forall a. Semigroup a => a -> a -> a
<> [FileMap] -> FileMap
forall a. Monoid a => [a] -> a
mconcat ((((Namespace, Name), QualName VName) -> FileMap)
-> [((Namespace, Name), QualName VName)] -> [FileMap]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> ((Namespace, Name), QualName VName) -> FileMap
forall {b}. FilePath -> ((Namespace, b), QualName VName) -> FileMap
vname' FilePath
prefix) ([((Namespace, Name), QualName VName)] -> [FileMap])
-> [((Namespace, Name), QualName VName)] -> [FileMap]
forall a b. (a -> b) -> a -> b
$ Map (Namespace, Name) (QualName VName)
-> [((Namespace, Name), QualName VName)]
forall k a. Map k a -> [(k, a)]
M.toList (Map (Namespace, Name) (QualName VName)
 -> [((Namespace, Name), QualName VName)])
-> Map (Namespace, Name) (QualName VName)
-> [((Namespace, Name), QualName VName)]
forall a b. (a -> b) -> a -> b
$ Env -> Map (Namespace, Name) (QualName VName)
envNameMap Env
env)
        forMod :: FilePath -> (VName, Mod) -> FileMap
forMod FilePath
prefix (VName
name, ModEnv Env
env) =
          FilePath -> Env -> FileMap
forEnv (FilePath
prefix FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> VName -> FilePath
baseString VName
name FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".") Env
env
        forMod FilePath
_ (VName
_, ModFun {}) = FileMap
forall a. Monoid a => a
mempty
        forMty :: FilePath -> (VName, MTy) -> FileMap
forMty FilePath
prefix (VName
name, MTy TySet
abs Mod
mod) =
          FilePath -> (VName, Mod) -> FileMap
forMod FilePath
prefix (VName
name, Mod
mod)
            FileMap -> FileMap -> FileMap
forall a. Semigroup a => a -> a -> a
<> [FileMap] -> FileMap
forall a. Monoid a => [a] -> a
mconcat ((QualName VName -> FileMap) -> [QualName VName] -> [FileMap]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Namespace -> QualName VName -> FileMap
vname FilePath
prefix Namespace
Type) (TySet -> [QualName VName]
forall k a. Map k a -> [k]
M.keys TySet
abs))
        forType :: FilePath -> (VName, b) -> FileMap
forType FilePath
prefix = FilePath -> Namespace -> QualName VName -> FileMap
vname FilePath
prefix Namespace
Type (QualName VName -> FileMap)
-> ((VName, b) -> QualName VName) -> (VName, b) -> FileMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> QualName VName
forall v. v -> QualName v
qualName (VName -> QualName VName)
-> ((VName, b) -> VName) -> (VName, b) -> QualName VName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VName, b) -> VName
forall a b. (a, b) -> a
fst

data Context = Context
  { Context -> FilePath
ctxCurrent :: String,
    Context -> FileModule
ctxFileMod :: FileModule,
    Context -> Imports
ctxImports :: Imports,
    Context -> NoLink
ctxNoLink :: NoLink,
    Context -> FileMap
ctxFileMap :: FileMap,
    -- | Local module types that show up in the interface. These
    -- should be documented, but clearly marked local.
    Context -> NoLink
ctxVisibleMTys :: S.Set VName
  }

-- | We keep a mapping of the names we have actually documented, so we
-- can generate an index.
type Documented = M.Map VName IndexWhat

type DocM = ReaderT Context (WriterT Documented (Writer Warnings))

data IndexWhat = IndexValue | IndexFunction | IndexModule | IndexModuleType | IndexType

warn :: Loc -> Doc () -> DocM ()
warn :: Loc -> Doc () -> DocM ()
warn Loc
loc Doc ()
s = WriterT Documented (Writer Warnings) () -> DocM ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT Documented (Writer Warnings) () -> DocM ())
-> WriterT Documented (Writer Warnings) () -> DocM ()
forall a b. (a -> b) -> a -> b
$ Writer Warnings () -> WriterT Documented (Writer Warnings) ()
forall (m :: * -> *) a. Monad m => m a -> WriterT Documented m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Writer Warnings () -> WriterT Documented (Writer Warnings) ())
-> Writer Warnings () -> WriterT Documented (Writer Warnings) ()
forall a b. (a -> b) -> a -> b
$ Warnings -> Writer Warnings ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Warnings -> Writer Warnings ()) -> Warnings -> Writer Warnings ()
forall a b. (a -> b) -> a -> b
$ Loc -> Doc () -> Warnings
singleWarning Loc
loc Doc ()
s

document :: VName -> IndexWhat -> DocM ()
document :: VName -> IndexWhat -> DocM ()
document VName
v IndexWhat
what = Documented -> DocM ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Documented -> DocM ()) -> Documented -> DocM ()
forall a b. (a -> b) -> a -> b
$ VName -> IndexWhat -> Documented
forall k a. k -> a -> Map k a
M.singleton VName
v IndexWhat
what

noLink :: [VName] -> DocM a -> DocM a
noLink :: forall a. [VName] -> DocM a -> DocM a
noLink [VName]
names = (Context -> Context)
-> ReaderT Context (WriterT Documented (Writer Warnings)) a
-> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall a.
(Context -> Context)
-> ReaderT Context (WriterT Documented (Writer Warnings)) a
-> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Context -> Context)
 -> ReaderT Context (WriterT Documented (Writer Warnings)) a
 -> ReaderT Context (WriterT Documented (Writer Warnings)) a)
-> (Context -> Context)
-> ReaderT Context (WriterT Documented (Writer Warnings)) a
-> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall a b. (a -> b) -> a -> b
$ \Context
ctx ->
  Context
ctx {ctxNoLink = S.fromList names <> ctxNoLink ctx}

selfLink :: AttributeValue -> Html -> Html
selfLink :: AttributeValue -> Html -> Html
selfLink AttributeValue
s = Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
s (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (AttributeValue
"#" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
s) (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"self_link"

fullRow :: Html -> Html
fullRow :: Html -> Html
fullRow = Html -> Html
H.tr (Html -> Html) -> (Html -> Html) -> Html -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Html -> Html
H.td (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.colspan AttributeValue
"3")

emptyRow :: Html
emptyRow :: Html
emptyRow = Html -> Html
H.tr (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"empty_spec_row" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.td Html
forall a. Monoid a => a
mempty Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html -> Html
H.td Html
forall a. Monoid a => a
mempty Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html -> Html
H.td Html
forall a. Monoid a => a
mempty

specRow :: Html -> Html -> Html -> Html
specRow :: Html -> Html -> Html -> Html
specRow Html
a Html
b Html
c =
  Html -> Html
H.tr (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
    (Html -> Html
H.td (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"spec_lhs") Html
a
      Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> (Html -> Html
H.td (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"spec_eql") Html
b
      Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> (Html -> Html
H.td (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"spec_rhs") Html
c

-- | The header documentation (which need not be present) can contain
-- an abstract and further sections.
headerDoc :: Prog -> DocM (Html, Html, Html)
headerDoc :: Prog -> DocM (Html, Html, Html)
headerDoc Prog
prog =
  case Prog -> Maybe DocComment
forall (f :: * -> *) vn. ProgBase f vn -> Maybe DocComment
progDoc Prog
prog of
    Just (DocComment Text
doc SrcLoc
loc) -> do
      let (FilePath
abstract, FilePath
more_sections) = FilePath -> (FilePath, FilePath)
splitHeaderDoc (FilePath -> (FilePath, FilePath))
-> FilePath -> (FilePath, FilePath)
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
doc
      first_paragraph <- Maybe DocComment -> DocM Html
docHtml (Maybe DocComment -> DocM Html) -> Maybe DocComment -> DocM Html
forall a b. (a -> b) -> a -> b
$ DocComment -> Maybe DocComment
forall a. a -> Maybe a
Just (DocComment -> Maybe DocComment) -> DocComment -> Maybe DocComment
forall a b. (a -> b) -> a -> b
$ Text -> SrcLoc -> DocComment
DocComment (FilePath -> Text
firstParagraph FilePath
abstract) SrcLoc
loc
      abstract' <- docHtml $ Just $ DocComment (T.pack abstract) loc
      more_sections' <- docHtml $ Just $ DocComment (T.pack more_sections) loc
      pure
        ( first_paragraph,
          selfLink "abstract" (H.h2 "Abstract") <> abstract',
          more_sections'
        )
    Maybe DocComment
_ -> (Html, Html, Html) -> DocM (Html, Html, Html)
forall a.
a -> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html, Html, Html)
forall a. Monoid a => a
mempty
  where
    splitHeaderDoc :: FilePath -> (FilePath, FilePath)
splitHeaderDoc FilePath
s =
      (FilePath, FilePath)
-> Maybe (FilePath, FilePath) -> (FilePath, FilePath)
forall a. a -> Maybe a -> a
fromMaybe (FilePath
s, FilePath
forall a. Monoid a => a
mempty) (Maybe (FilePath, FilePath) -> (FilePath, FilePath))
-> Maybe (FilePath, FilePath) -> (FilePath, FilePath)
forall a b. (a -> b) -> a -> b
$
        ((FilePath, FilePath) -> Bool)
-> [(FilePath, FilePath)] -> Maybe (FilePath, FilePath)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((FilePath
"\n##" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) (FilePath -> Bool)
-> ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> b
snd) ([(FilePath, FilePath)] -> Maybe (FilePath, FilePath))
-> [(FilePath, FilePath)] -> Maybe (FilePath, FilePath)
forall a b. (a -> b) -> a -> b
$
          [FilePath] -> [FilePath] -> [(FilePath, FilePath)]
forall a b. [a] -> [b] -> [(a, b)]
zip (FilePath -> [FilePath]
forall a. [a] -> [[a]]
inits FilePath
s) (FilePath -> [FilePath]
forall a. [a] -> [[a]]
tails FilePath
s)
    firstParagraph :: FilePath -> Text
firstParagraph = FilePath -> Text
T.pack (FilePath -> Text) -> (FilePath -> FilePath) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unlines ([FilePath] -> FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
paragraphSeparator) ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines
    paragraphSeparator :: FilePath -> Bool
paragraphSeparator = (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace

contentsPage :: [ImportName] -> [(ImportName, Html)] -> Html
contentsPage :: [ImportName] -> [(ImportName, Html)] -> Html
contentsPage [ImportName]
important_imports [(ImportName, Html)]
pages =
  Html -> Html
H.docTypeHtml (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
    FilePath -> FilePath -> Html -> Html
addBoilerplate FilePath
"index.html" FilePath
"Futhark Library Documentation" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
      Html -> Html
H.main (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
        ( if [(ImportName, Html)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ImportName, Html)]
important_pages
            then Html
forall a. Monoid a => a
mempty
            else Html -> Html
H.h2 Html
"Main libraries" Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> [(ImportName, Html)] -> Html
fileList [(ImportName, Html)]
important_pages
        )
          Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> ( if [(ImportName, Html)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ImportName, Html)]
unimportant_pages
                 then Html
forall a. Monoid a => a
mempty
                 else Html -> Html
H.h2 Html
"Supporting libraries" Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> [(ImportName, Html)] -> Html
fileList [(ImportName, Html)]
unimportant_pages
             )
  where
    ([(ImportName, Html)]
important_pages, [(ImportName, Html)]
unimportant_pages) =
      ((ImportName, Html) -> Bool)
-> [(ImportName, Html)]
-> ([(ImportName, Html)], [(ImportName, Html)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((ImportName -> [ImportName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ImportName]
important_imports) (ImportName -> Bool)
-> ((ImportName, Html) -> ImportName) -> (ImportName, Html) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ImportName, Html) -> ImportName
forall a b. (a, b) -> a
fst) [(ImportName, Html)]
pages

    fileList :: [(ImportName, Html)] -> Html
fileList [(ImportName, Html)]
pages' =
      Html -> Html
H.dl (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"file_list" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
        [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html) -> [Html] -> Html
forall a b. (a -> b) -> a -> b
$
          ((ImportName, Html) -> Html) -> [(ImportName, Html)] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map (ImportName, Html) -> Html
linkTo ([(ImportName, Html)] -> [Html]) -> [(ImportName, Html)] -> [Html]
forall a b. (a -> b) -> a -> b
$
            ((ImportName, Html) -> ImportName)
-> [(ImportName, Html)] -> [(ImportName, Html)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (ImportName, Html) -> ImportName
forall a b. (a, b) -> a
fst [(ImportName, Html)]
pages'

    linkTo :: (ImportName, Html) -> Html
linkTo (ImportName
name, Html
maybe_abstract) =
      Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"file_desc" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
        (Html -> Html
H.dt (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"desc_header") (FilePath -> ImportName -> Html
importLink FilePath
"index.html" ImportName
name)
          Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> (Html -> Html
H.dd (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"desc_doc") Html
maybe_abstract

importLink :: FilePath -> ImportName -> Html
importLink :: FilePath -> ImportName -> Html
importLink FilePath
current ImportName
name =
  let file :: FilePath
file =
        FilePath -> FilePath -> FilePath
relativise
          (FilePath
"doc" FilePath -> FilePath -> FilePath
</> FilePath -> FilePath -> FilePath
makeRelative FilePath
"/" (ImportName -> FilePath
includeToFilePath ImportName
name) FilePath -> FilePath -> FilePath
-<.> FilePath
"html")
          FilePath
current
   in (Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (FilePath -> AttributeValue
forall a. IsString a => FilePath -> a
fromString FilePath
file) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ FilePath -> Html
forall a. IsString a => FilePath -> a
fromString (ImportName -> FilePath
includeToString ImportName
name))

indexPage :: [ImportName] -> Imports -> Documented -> FileMap -> Html
indexPage :: [ImportName] -> Imports -> Documented -> FileMap -> Html
indexPage [ImportName]
important_imports Imports
imports Documented
documented FileMap
fm =
  Html -> Html
H.docTypeHtml (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
    [ImportName] -> Imports -> FilePath -> FilePath -> Html -> Html
addBoilerplateWithNav [ImportName]
important_imports Imports
imports FilePath
"doc-index.html" FilePath
"Index" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
      Html -> Html
H.main (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
        ( Html -> Html
H.ul (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"doc_index_list" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
            [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html) -> [Html] -> Html
forall a b. (a -> b) -> a -> b
$
              (FilePath -> Html) -> [FilePath] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Html
initialListEntry ([FilePath] -> [Html]) -> [FilePath] -> [Html]
forall a b. (a -> b) -> a -> b
$
                [FilePath]
letter_group_links [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
symbol_group_link]
        )
          Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> ( Html -> Html
H.table (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"doc_index" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
                 Html -> Html
H.thead (Html -> Html
H.tr (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.td Html
"Who" Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html -> Html
H.td Html
"What" Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html -> Html
H.td Html
"Where")
                   Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html]
letter_groups [Html] -> [Html] -> [Html]
forall a. [a] -> [a] -> [a]
++ [Html
symbol_group])
             )
  where
    ([(VName, (FilePath, (IndexWhat, FilePath)))]
letter_names, [(VName, (FilePath, (IndexWhat, FilePath)))]
sym_names) =
      ((VName, (FilePath, (IndexWhat, FilePath))) -> Bool)
-> [(VName, (FilePath, (IndexWhat, FilePath)))]
-> ([(VName, (FilePath, (IndexWhat, FilePath)))],
    [(VName, (FilePath, (IndexWhat, FilePath)))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (FilePath -> Bool
isLetterName (FilePath -> Bool)
-> ((VName, (FilePath, (IndexWhat, FilePath))) -> FilePath)
-> (VName, (FilePath, (IndexWhat, FilePath)))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> FilePath
baseString (VName -> FilePath)
-> ((VName, (FilePath, (IndexWhat, FilePath))) -> VName)
-> (VName, (FilePath, (IndexWhat, FilePath)))
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VName, (FilePath, (IndexWhat, FilePath))) -> VName
forall a b. (a, b) -> a
fst) ([(VName, (FilePath, (IndexWhat, FilePath)))]
 -> ([(VName, (FilePath, (IndexWhat, FilePath)))],
     [(VName, (FilePath, (IndexWhat, FilePath)))]))
-> [(VName, (FilePath, (IndexWhat, FilePath)))]
-> ([(VName, (FilePath, (IndexWhat, FilePath)))],
    [(VName, (FilePath, (IndexWhat, FilePath)))])
forall a b. (a -> b) -> a -> b
$
        ((VName, (FilePath, (IndexWhat, FilePath))) -> FilePath)
-> [(VName, (FilePath, (IndexWhat, FilePath)))]
-> [(VName, (FilePath, (IndexWhat, FilePath)))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ((Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (FilePath -> FilePath)
-> ((VName, (FilePath, (IndexWhat, FilePath))) -> FilePath)
-> (VName, (FilePath, (IndexWhat, FilePath)))
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> FilePath
baseString (VName -> FilePath)
-> ((VName, (FilePath, (IndexWhat, FilePath))) -> VName)
-> (VName, (FilePath, (IndexWhat, FilePath)))
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VName, (FilePath, (IndexWhat, FilePath))) -> VName
forall a b. (a, b) -> a
fst) ([(VName, (FilePath, (IndexWhat, FilePath)))]
 -> [(VName, (FilePath, (IndexWhat, FilePath)))])
-> [(VName, (FilePath, (IndexWhat, FilePath)))]
-> [(VName, (FilePath, (IndexWhat, FilePath)))]
forall a b. (a -> b) -> a -> b
$
          ((VName, (FilePath, FilePath))
 -> Maybe (VName, (FilePath, (IndexWhat, FilePath))))
-> [(VName, (FilePath, FilePath))]
-> [(VName, (FilePath, (IndexWhat, FilePath)))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (VName, (FilePath, FilePath))
-> Maybe (VName, (FilePath, (IndexWhat, FilePath)))
forall {a} {b}.
(VName, (a, b)) -> Maybe (VName, (a, (IndexWhat, b)))
isDocumented ([(VName, (FilePath, FilePath))]
 -> [(VName, (FilePath, (IndexWhat, FilePath)))])
-> [(VName, (FilePath, FilePath))]
-> [(VName, (FilePath, (IndexWhat, FilePath)))]
forall a b. (a -> b) -> a -> b
$
            FileMap -> [(VName, (FilePath, FilePath))]
forall k a. Map k a -> [(k, a)]
M.toList FileMap
fm

    isDocumented :: (VName, (a, b)) -> Maybe (VName, (a, (IndexWhat, b)))
isDocumented (VName
k, (a
file, b
k_id)) = do
      what <- VName -> Documented -> Maybe IndexWhat
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
k Documented
documented
      Just (k, (file, (what, k_id)))

    ([Html]
letter_groups, [FilePath]
letter_group_links) =
      [(Html, FilePath)] -> ([Html], [FilePath])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Html, FilePath)] -> ([Html], [FilePath]))
-> [(Html, FilePath)] -> ([Html], [FilePath])
forall a b. (a -> b) -> a -> b
$ ([(VName, (FilePath, (IndexWhat, FilePath)))] -> (Html, FilePath))
-> [[(VName, (FilePath, (IndexWhat, FilePath)))]]
-> [(Html, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map [(VName, (FilePath, (IndexWhat, FilePath)))] -> (Html, FilePath)
tbodyForNames ([[(VName, (FilePath, (IndexWhat, FilePath)))]]
 -> [(Html, FilePath)])
-> [[(VName, (FilePath, (IndexWhat, FilePath)))]]
-> [(Html, FilePath)]
forall a b. (a -> b) -> a -> b
$ ((VName, (FilePath, (IndexWhat, FilePath)))
 -> (VName, (FilePath, (IndexWhat, FilePath))) -> Bool)
-> [(VName, (FilePath, (IndexWhat, FilePath)))]
-> [[(VName, (FilePath, (IndexWhat, FilePath)))]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (VName, (FilePath, (IndexWhat, FilePath)))
-> (VName, (FilePath, (IndexWhat, FilePath))) -> Bool
forall {b} {b}. (VName, b) -> (VName, b) -> Bool
sameInitial [(VName, (FilePath, (IndexWhat, FilePath)))]
letter_names
    (Html
symbol_group, FilePath
symbol_group_link) =
      FilePath
-> [(VName, (FilePath, (IndexWhat, FilePath)))] -> (Html, FilePath)
tbodyForInitial FilePath
"Symbols" [(VName, (FilePath, (IndexWhat, FilePath)))]
sym_names

    isLetterName :: FilePath -> Bool
isLetterName [] = Bool
False
    isLetterName (Char
c : FilePath
_) = Char -> Bool
isAlpha Char
c

    sameInitial :: (VName, b) -> (VName, b) -> Bool
sameInitial (VName
x, b
_) (VName
y, b
_) =
      case (VName -> FilePath
baseString VName
x, VName -> FilePath
baseString VName
y) of
        (Char
x' : FilePath
_, Char
y' : FilePath
_) -> Char -> Char
toUpper Char
x' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Char
toUpper Char
y'
        (FilePath, FilePath)
_ -> Bool
False

    tbodyForNames :: [(VName, (FilePath, (IndexWhat, FilePath)))] -> (Html, FilePath)
tbodyForNames names :: [(VName, (FilePath, (IndexWhat, FilePath)))]
names@((VName
s, (FilePath, (IndexWhat, FilePath))
_) : [(VName, (FilePath, (IndexWhat, FilePath)))]
_) =
      FilePath
-> [(VName, (FilePath, (IndexWhat, FilePath)))] -> (Html, FilePath)
tbodyForInitial ((Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take Int
1 (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ VName -> FilePath
baseString VName
s) [(VName, (FilePath, (IndexWhat, FilePath)))]
names
    tbodyForNames [(VName, (FilePath, (IndexWhat, FilePath)))]
_ = (Html, FilePath)
forall a. Monoid a => a
mempty

    tbodyForInitial :: FilePath
-> [(VName, (FilePath, (IndexWhat, FilePath)))] -> (Html, FilePath)
tbodyForInitial FilePath
initial [(VName, (FilePath, (IndexWhat, FilePath)))]
names =
      ( Html -> Html
H.tbody (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html) -> [Html] -> Html
forall a b. (a -> b) -> a -> b
$ Html
initial' Html -> [Html] -> [Html]
forall a. a -> [a] -> [a]
: ((VName, (FilePath, (IndexWhat, FilePath))) -> Html)
-> [(VName, (FilePath, (IndexWhat, FilePath)))] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map (VName, (FilePath, (IndexWhat, FilePath))) -> Html
linkTo [(VName, (FilePath, (IndexWhat, FilePath)))]
names,
        FilePath
initial
      )
      where
        initial' :: Html
initial' =
          Html -> Html
H.tr
            (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.td (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.colspan AttributeValue
"2" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"doc_index_initial"
            (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
A.id (FilePath -> AttributeValue
forall a. IsString a => FilePath -> a
fromString FilePath
initial)
              (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (FilePath -> AttributeValue
forall a. IsString a => FilePath -> a
fromString (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Char
'#' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
initial)
            (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ FilePath -> Html
forall a. IsString a => FilePath -> a
fromString FilePath
initial

    initialListEntry :: FilePath -> Html
initialListEntry FilePath
initial =
      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
A.href (FilePath -> AttributeValue
forall a. IsString a => FilePath -> a
fromString (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Char
'#' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
initial) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ FilePath -> Html
forall a. IsString a => FilePath -> a
fromString FilePath
initial

    linkTo :: (VName, (FilePath, (IndexWhat, FilePath))) -> Html
linkTo (VName
name, (FilePath
file, (IndexWhat
what, FilePath
name_id))) =
      let file' :: FilePath
file' = FilePath -> FilePath -> FilePath
makeRelative FilePath
"/" FilePath
file
          name_link :: FilePath
name_link = FilePath -> FilePath -> FilePath -> FilePath
vnameLink' FilePath
name_id FilePath
"" FilePath
file'
          link :: Html
link =
            (Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (FilePath -> AttributeValue
forall a. IsString a => FilePath -> a
fromString (FilePath -> FilePath -> FilePath
makeRelative FilePath
"/" (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"doc" FilePath -> FilePath -> FilePath
</> FilePath
name_link))) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
              FilePath -> Html
forall a. IsString a => FilePath -> a
fromString (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$
                VName -> FilePath
baseString VName
name
          what' :: Html
what' = case IndexWhat
what of
            IndexWhat
IndexValue -> Html
"value"
            IndexWhat
IndexFunction -> Html
"function"
            IndexWhat
IndexType -> Html
"type"
            IndexWhat
IndexModuleType -> Html
"module type"
            IndexWhat
IndexModule -> Html
"module"
          html_file :: FilePath
html_file = FilePath
"doc" FilePath -> FilePath -> FilePath
</> FilePath
file' FilePath -> FilePath -> FilePath
-<.> FilePath
"html"
       in Html -> Html
H.tr (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
            (Html -> Html
H.td (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"doc_index_name" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
link)
              Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> (Html -> Html
H.td (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"doc_index_namespace" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
what')
              Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> ( Html -> Html
H.td (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"doc_index_file" (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
A.href (FilePath -> AttributeValue
forall a. IsString a => FilePath -> a
fromString FilePath
html_file) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ FilePath -> Html
forall a. IsString a => FilePath -> a
fromString FilePath
file)
                 )

addBoilerplate :: String -> String -> Html -> Html
addBoilerplate :: FilePath -> FilePath -> Html -> Html
addBoilerplate FilePath
current FilePath
titleText Html
content =
  let navigation :: Html
navigation =
        Html -> Html
H.ul (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"navigation" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
          Html -> Html
H.li (Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (FilePath -> AttributeValue
forall a. IsString a => FilePath -> a
fromString (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath
relativise FilePath
"index.html" FilePath
current) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Contents")
            Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html -> Html
H.li (Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (FilePath -> AttributeValue
forall a. IsString a => FilePath -> a
fromString (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath
relativise FilePath
"doc-index.html" FilePath
current) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Index")

      madeByHtml :: Html
madeByHtml =
        Html
"Generated by "
          Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> (Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href AttributeValue
futhark_doc_url) Html
"futhark-doc"
          Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
" "
          Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> FilePath -> Html
forall a. IsString a => FilePath -> a
fromString (Version -> FilePath
showVersion Version
version)
   in FilePath -> FilePath -> Html
headHtml FilePath
current FilePath
titleText
        Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html -> Html
H.body
          ( (Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"header") (Html -> Html
H.h1 (FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml FilePath
titleText) Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
navigation)
              Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> (Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"content") Html
content
              Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> (Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"footer") Html
madeByHtml
          )
  where
    futhark_doc_url :: AttributeValue
futhark_doc_url =
      AttributeValue
"https://futhark.readthedocs.io/en/latest/man/futhark-doc.html"

addBoilerplateWithNav :: [ImportName] -> Imports -> String -> String -> Html -> Html
addBoilerplateWithNav :: [ImportName] -> Imports -> FilePath -> FilePath -> Html -> Html
addBoilerplateWithNav [ImportName]
important_imports Imports
imports FilePath
current FilePath
titleText Html
content =
  FilePath -> FilePath -> Html -> Html
addBoilerplate FilePath
current FilePath
titleText (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
    (Html -> Html
H.nav (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"filenav" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
files) Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
content
  where
    files :: Html
files = Html -> Html
H.ul (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html) -> [Html] -> Html
forall a b. (a -> b) -> a -> b
$ (ImportName -> Html) -> [ImportName] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map ImportName -> Html
pp ([ImportName] -> [Html]) -> [ImportName] -> [Html]
forall a b. (a -> b) -> a -> b
$ [ImportName] -> [ImportName]
forall a. Ord a => [a] -> [a]
sort ([ImportName] -> [ImportName]) -> [ImportName] -> [ImportName]
forall a b. (a -> b) -> a -> b
$ (ImportName -> Bool) -> [ImportName] -> [ImportName]
forall a. (a -> Bool) -> [a] -> [a]
filter ImportName -> Bool
visible [ImportName]
important_imports
    pp :: ImportName -> Html
pp ImportName
name = Html -> Html
H.li (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ FilePath -> ImportName -> Html
importLink FilePath
current ImportName
name
    visible :: ImportName -> Bool
visible = (ImportName -> [ImportName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((ImportName, FileModule) -> ImportName) -> Imports -> [ImportName]
forall a b. (a -> b) -> [a] -> [b]
map (ImportName, FileModule) -> ImportName
forall a b. (a, b) -> a
fst Imports
imports)

synopsisDecs :: [Dec] -> DocM Html
synopsisDecs :: [Dec] -> DocM Html
synopsisDecs [Dec]
decs = do
  visible <- (Context -> NoLink)
-> ReaderT Context (WriterT Documented (Writer Warnings)) NoLink
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> NoLink
ctxVisibleMTys
  fm <- asks ctxFileMod
  -- We add an empty row to avoid generating invalid HTML in cases
  -- where all rows are otherwise colspan=2.
  (H.table ! A.class_ "specs") . (emptyRow <>) . mconcat
    <$> sequence (mapMaybe (synopsisDec visible fm) decs)

synopsisDec :: S.Set VName -> FileModule -> Dec -> Maybe (DocM Html)
synopsisDec :: NoLink -> FileModule -> Dec -> Maybe (DocM Html)
synopsisDec NoLink
visible FileModule
fm Dec
dec = case Dec
dec of
  ModTypeDec ModTypeBindBase Info VName
s -> Html -> ModTypeBindBase Info VName -> Maybe (DocM Html)
synopsisModType Html
forall a. Monoid a => a
mempty ModTypeBindBase Info VName
s
  ModDec ModBindBase Info VName
m -> FileModule -> ModBindBase Info VName -> Maybe (DocM Html)
synopsisMod FileModule
fm ModBindBase Info VName
m
  ValDec ValBindBase Info VName
v -> ValBindBase Info VName -> Maybe (DocM Html)
synopsisValBind ValBindBase Info VName
v
  TypeDec TypeBindBase Info VName
t -> TypeBindBase Info VName -> Maybe (DocM Html)
synopsisType TypeBindBase Info VName
t
  OpenDec ModExpBase Info VName
x SrcLoc
_
    | Just DocM Html
opened <- ModExpBase Info VName -> Maybe (DocM Html)
synopsisOpened ModExpBase Info VName
x -> DocM Html -> Maybe (DocM Html)
forall a. a -> Maybe a
Just (DocM Html -> Maybe (DocM Html)) -> DocM Html -> Maybe (DocM Html)
forall a b. (a -> b) -> a -> b
$ do
        opened' <- DocM Html
opened
        pure $ fullRow $ keyword "open " <> opened'
    | Bool
otherwise ->
        DocM Html -> Maybe (DocM Html)
forall a. a -> Maybe a
Just (DocM Html -> Maybe (DocM Html)) -> DocM Html -> Maybe (DocM Html)
forall a b. (a -> b) -> a -> b
$
          Html -> DocM Html
forall a.
a -> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html -> DocM Html) -> Html -> DocM Html
forall a b. (a -> b) -> a -> b
$
            Html -> Html
fullRow (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
              FilePath -> Html
keyword FilePath
"open" Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> FilePath -> Html
forall a. IsString a => FilePath -> a
fromString (FilePath
" <" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> ModExpBase Info VName -> FilePath
forall a. Pretty a => a -> FilePath
prettyString ModExpBase Info VName
x FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
">")
  LocalDec (ModTypeDec ModTypeBindBase Info VName
s) SrcLoc
_
    | ModTypeBindBase Info VName -> VName
forall (f :: * -> *) vn. ModTypeBindBase f vn -> vn
modTypeName ModTypeBindBase Info VName
s VName -> NoLink -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` NoLink
visible ->
        Html -> ModTypeBindBase Info VName -> Maybe (DocM Html)
synopsisModType (FilePath -> Html
keyword FilePath
"local" Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
" ") ModTypeBindBase Info VName
s
  LocalDec {} -> Maybe (DocM Html)
forall a. Maybe a
Nothing
  ImportDec {} -> Maybe (DocM Html)
forall a. Maybe a
Nothing

synopsisOpened :: ModExp -> Maybe (DocM Html)
synopsisOpened :: ModExpBase Info VName -> Maybe (DocM Html)
synopsisOpened (ModVar QualName VName
qn SrcLoc
_) = DocM Html -> Maybe (DocM Html)
forall a. a -> Maybe a
Just (DocM Html -> Maybe (DocM Html)) -> DocM Html -> Maybe (DocM Html)
forall a b. (a -> b) -> a -> b
$ QualName VName -> DocM Html
qualNameHtml QualName VName
qn
synopsisOpened (ModParens ModExpBase Info VName
me SrcLoc
_) = do
  me' <- ModExpBase Info VName -> Maybe (DocM Html)
synopsisOpened ModExpBase Info VName
me
  Just $ parens <$> me'
synopsisOpened (ModImport FilePath
_ (Info ImportName
file) SrcLoc
_) = DocM Html -> Maybe (DocM Html)
forall a. a -> Maybe a
Just (DocM Html -> Maybe (DocM Html)) -> DocM Html -> Maybe (DocM Html)
forall a b. (a -> b) -> a -> b
$ do
  current <- (Context -> FilePath)
-> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> FilePath
ctxCurrent
  let dest = FilePath -> AttributeValue
forall a. IsString a => FilePath -> a
fromString (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath
relativise (ImportName -> FilePath
includeToFilePath ImportName
file) FilePath
current FilePath -> FilePath -> FilePath
-<.> FilePath
"html"
  pure $
    keyword "import "
      <> (H.a ! A.href dest) (fromString (show (includeToString file)))
synopsisOpened (ModAscript ModExpBase Info VName
_ ModTypeExpBase Info VName
se Info (Map VName VName)
_ SrcLoc
_) = DocM Html -> Maybe (DocM Html)
forall a. a -> Maybe a
Just (DocM Html -> Maybe (DocM Html)) -> DocM Html -> Maybe (DocM Html)
forall a b. (a -> b) -> a -> b
$ do
  se' <- ModTypeExpBase Info VName -> DocM Html
synopsisModTypeExp ModTypeExpBase Info VName
se
  pure $ "... : " <> se'
synopsisOpened ModExpBase Info VName
_ = Maybe (DocM Html)
forall a. Maybe a
Nothing

vnameSynopsisDef :: VName -> DocM Html
vnameSynopsisDef :: VName -> DocM Html
vnameSynopsisDef VName
vname = do
  (_, vname_id) <- VName -> DocM (FilePath, FilePath)
vnameId VName
vname
  pure $
    H.span ! A.id (fromString ("synopsis:" <> vname_id)) $
      H.a ! A.href (fromString ("#" ++ vname_id)) $
        if symbolName (baseName vname)
          then parens (renderName (baseName vname))
          else renderName (baseName vname)

synopsisValBind :: ValBind -> Maybe (DocM Html)
synopsisValBind :: ValBindBase Info VName -> Maybe (DocM Html)
synopsisValBind ValBindBase Info VName
vb = DocM Html -> Maybe (DocM Html)
forall a. a -> Maybe a
Just (DocM Html -> Maybe (DocM Html)) -> DocM Html -> Maybe (DocM Html)
forall a b. (a -> b) -> a -> b
$ do
  name' <- VName -> DocM Html
vnameSynopsisDef (VName -> DocM Html) -> VName -> DocM Html
forall a b. (a -> b) -> a -> b
$ ValBindBase Info VName -> VName
forall (f :: * -> *) vn. ValBindBase f vn -> vn
valBindName ValBindBase Info VName
vb
  (lhs, mhs, rhs) <- valBindHtml name' vb
  pure $ specRow lhs (mhs <> " : ") rhs

valBindHtml :: Html -> ValBind -> DocM (Html, Html, Html)
valBindHtml :: Html -> ValBindBase Info VName -> DocM (Html, Html, Html)
valBindHtml Html
name (ValBind Maybe (Info EntryPoint)
_ VName
_ SrcLoc
_ Maybe (TypeExp Size VName)
retdecl (Info ResRetType
rettype) [TypeParamBase VName]
tparams [PatBase Info VName ParamType]
params Size
_ Maybe DocComment
_ [AttrInfo VName]
_ SrcLoc
_) = do
  tparams' <- [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html)
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
-> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeParamBase VName -> DocM Html)
-> [TypeParamBase VName]
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Html -> Html) -> DocM Html -> DocM Html
forall a b.
(a -> b)
-> ReaderT Context (WriterT Documented (Writer Warnings)) a
-> ReaderT Context (WriterT Documented (Writer Warnings)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Html
" " Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<>) (DocM Html -> DocM Html)
-> (TypeParamBase VName -> DocM Html)
-> TypeParamBase VName
-> DocM Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeParamBase VName -> DocM Html
typeParamHtml) [TypeParamBase VName]
tparams
  let noLink' = [VName] -> DocM a -> DocM a
forall a. [VName] -> DocM a -> DocM a
noLink ([VName] -> DocM a -> DocM a) -> [VName] -> DocM a -> DocM a
forall a b. (a -> b) -> a -> b
$ (TypeParamBase VName -> VName) -> [TypeParamBase VName] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map TypeParamBase VName -> VName
forall vn. TypeParamBase vn -> vn
typeParamName [TypeParamBase VName]
tparams [VName] -> [VName] -> [VName]
forall a. Semigroup a => a -> a -> a
<> (PatBase Info VName ParamType -> [VName])
-> [PatBase Info VName ParamType] -> [VName]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap PatBase Info VName ParamType -> [VName]
forall t. Pat t -> [VName]
patNames [PatBase Info VName ParamType]
params
  rettype' <- noLink' $ maybe (retTypeHtml rettype) typeExpHtml retdecl
  params' <- noLink' $ mapM paramHtml params
  pure
    ( keyword "val " <> (H.span ! A.class_ "decl_name") name,
      tparams',
      mconcat (intersperse " -> " $ params' ++ [rettype'])
    )

synopsisModType :: Html -> ModTypeBind -> Maybe (DocM Html)
synopsisModType :: Html -> ModTypeBindBase Info VName -> Maybe (DocM Html)
synopsisModType Html
prefix ModTypeBindBase Info VName
sb = DocM Html -> Maybe (DocM Html)
forall a. a -> Maybe a
Just (DocM Html -> Maybe (DocM Html)) -> DocM Html -> Maybe (DocM Html)
forall a b. (a -> b) -> a -> b
$ do
  name' <- VName -> DocM Html
vnameSynopsisDef (VName -> DocM Html) -> VName -> DocM Html
forall a b. (a -> b) -> a -> b
$ ModTypeBindBase Info VName -> VName
forall (f :: * -> *) vn. ModTypeBindBase f vn -> vn
modTypeName ModTypeBindBase Info VName
sb
  fullRow <$> do
    se' <- synopsisModTypeExp $ modTypeExp sb
    pure $ prefix <> keyword "module type " <> name' <> " = " <> se'

synopsisMod :: FileModule -> ModBind -> Maybe (DocM Html)
synopsisMod :: FileModule -> ModBindBase Info VName -> Maybe (DocM Html)
synopsisMod FileModule
fm (ModBind VName
name [ModParamBase Info VName]
ps Maybe (ModTypeExpBase Info VName, Info (Map VName VName))
sig ModExpBase Info VName
_ Maybe DocComment
_ SrcLoc
_) =
  case Maybe (ModTypeExpBase Info VName, Info (Map VName VName))
sig of
    Maybe (ModTypeExpBase Info VName, Info (Map VName VName))
Nothing -> (Html -> DocM Html
proceed (Html -> DocM Html) -> (Mod -> DocM Html) -> Mod -> DocM Html
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Mod -> DocM Html
envModType) (Mod -> DocM Html) -> Maybe Mod -> Maybe (DocM Html)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> Map VName Mod -> Maybe Mod
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
name Map VName Mod
modtable
    Just (ModTypeExpBase Info VName
s, Info (Map VName VName)
_) -> DocM Html -> Maybe (DocM Html)
forall a. a -> Maybe a
Just (DocM Html -> Maybe (DocM Html)) -> DocM Html -> Maybe (DocM Html)
forall a b. (a -> b) -> a -> b
$ Html -> DocM Html
proceed (Html -> DocM Html) -> DocM Html -> DocM Html
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ModTypeExpBase Info VName -> DocM Html
synopsisModTypeExp ModTypeExpBase Info VName
s
  where
    proceed :: Html -> DocM Html
proceed Html
sig' = do
      name' <- VName -> DocM Html
vnameSynopsisDef VName
name
      ps' <- modParamHtml ps
      pure $ specRow (keyword "module " <> name') ": " (ps' <> sig')

    FileModule TySet
_abs Env {envModTable :: Env -> Map VName Mod
envModTable = Map VName Mod
modtable} Prog
_ Env
_ = FileModule
fm
    envModType :: Mod -> DocM Html
envModType (ModEnv Env
e) = Env -> DocM Html
renderEnv Env
e
    envModType (ModFun (FunModType TySet
_ Mod
_ (MTy TySet
_ Mod
m))) = Mod -> DocM Html
envModType Mod
m

synopsisType :: TypeBind -> Maybe (DocM Html)
synopsisType :: TypeBindBase Info VName -> Maybe (DocM Html)
synopsisType TypeBindBase Info VName
tb = DocM Html -> Maybe (DocM Html)
forall a. a -> Maybe a
Just (DocM Html -> Maybe (DocM Html)) -> DocM Html -> Maybe (DocM Html)
forall a b. (a -> b) -> a -> b
$ do
  name' <- VName -> DocM Html
vnameSynopsisDef (VName -> DocM Html) -> VName -> DocM Html
forall a b. (a -> b) -> a -> b
$ TypeBindBase Info VName -> VName
forall (f :: * -> *) vn. TypeBindBase f vn -> vn
typeAlias TypeBindBase Info VName
tb
  fullRow <$> typeBindHtml name' tb

typeBindHtml :: Html -> TypeBind -> DocM Html
typeBindHtml :: Html -> TypeBindBase Info VName -> DocM Html
typeBindHtml Html
name' (TypeBind VName
_ Liftedness
l [TypeParamBase VName]
tparams TypeExp Size VName
t Info StructRetType
_ Maybe DocComment
_ SrcLoc
_) = do
  t' <- [VName] -> DocM Html -> DocM Html
forall a. [VName] -> DocM a -> DocM a
noLink ((TypeParamBase VName -> VName) -> [TypeParamBase VName] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map TypeParamBase VName -> VName
forall vn. TypeParamBase vn -> vn
typeParamName [TypeParamBase VName]
tparams) (DocM Html -> DocM Html) -> DocM Html -> DocM Html
forall a b. (a -> b) -> a -> b
$ TypeExp Size VName -> DocM Html
typeExpHtml TypeExp Size VName
t
  abbrev <- typeAbbrevHtml l name' tparams
  pure $ abbrev <> " = " <> t'

renderEnv :: Env -> DocM Html
renderEnv :: Env -> DocM Html
renderEnv (Env Map VName BoundV
vtable Map VName TypeBinding
ttable Map VName MTy
sigtable Map VName Mod
modtable Map (Namespace, Name) (QualName VName)
_) = do
  typeBinds <- ((VName, TypeBinding) -> DocM Html)
-> [(VName, TypeBinding)]
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (VName, TypeBinding) -> DocM Html
renderTypeBind (Map VName TypeBinding -> [(VName, TypeBinding)]
forall k a. Map k a -> [(k, a)]
M.toList Map VName TypeBinding
ttable)
  valBinds <- mapM renderValBind (M.toList vtable)
  sigBinds <- mapM renderModType (M.toList sigtable)
  modBinds <- mapM renderMod (M.toList modtable)
  pure $ braces $ mconcat $ typeBinds ++ valBinds ++ sigBinds ++ modBinds

renderModType :: (VName, MTy) -> DocM Html
renderModType :: (VName, MTy) -> DocM Html
renderModType (VName
name, MTy
_sig) =
  (FilePath -> Html
keyword FilePath
"module type " Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<>) (Html -> Html) -> DocM Html -> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualName VName -> DocM Html
qualNameHtml (VName -> QualName VName
forall v. v -> QualName v
qualName VName
name)

renderMod :: (VName, Mod) -> DocM Html
renderMod :: (VName, Mod) -> DocM Html
renderMod (VName
name, Mod
_mod) =
  (FilePath -> Html
keyword FilePath
"module " Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<>) (Html -> Html) -> DocM Html -> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualName VName -> DocM Html
qualNameHtml (VName -> QualName VName
forall v. v -> QualName v
qualName VName
name)

renderValBind :: (VName, BoundV) -> DocM Html
renderValBind :: (VName, BoundV) -> DocM Html
renderValBind = (Html -> Html) -> DocM Html -> DocM Html
forall a b.
(a -> b)
-> ReaderT Context (WriterT Documented (Writer Warnings)) a
-> ReaderT Context (WriterT Documented (Writer Warnings)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Html -> Html
H.div (DocM Html -> DocM Html)
-> ((VName, BoundV) -> DocM Html) -> (VName, BoundV) -> DocM Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VName, BoundV) -> DocM Html
synopsisValBindBind

renderTypeBind :: (VName, TypeBinding) -> DocM Html
renderTypeBind :: (VName, TypeBinding) -> DocM Html
renderTypeBind (VName
name, TypeAbbr Liftedness
l [TypeParamBase VName]
tps StructRetType
tp) = do
  tp' <- ResRetType -> DocM Html
retTypeHtml (ResRetType -> DocM Html) -> ResRetType -> DocM Html
forall a b. (a -> b) -> a -> b
$ Freshness -> StructRetType -> ResRetType
forall o. Freshness -> RetTypeBase Size o -> ResRetType
toResRet Freshness
Nonfresh StructRetType
tp
  name' <- vnameHtml name
  abbrev <- typeAbbrevHtml l name' tps
  pure $ H.div $ abbrev <> " = " <> tp'

synopsisValBindBind :: (VName, BoundV) -> DocM Html
synopsisValBindBind :: (VName, BoundV) -> DocM Html
synopsisValBindBind (VName
name, BoundV [TypeParamBase VName]
tps StructType
t) = do
  tps' <- (TypeParamBase VName -> DocM Html)
-> [TypeParamBase VName]
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TypeParamBase VName -> DocM Html
typeParamHtml [TypeParamBase VName]
tps
  t' <- typeHtml $ second (const Nonfresh) t
  name' <- vnameHtml name
  pure $ keyword "val " <> name' <> mconcat (map (" " <>) tps') <> ": " <> t'

dietHtml :: Diet -> Html
dietHtml :: Diet -> Html
dietHtml Diet
Consume = Html
"*"
dietHtml Diet
Observe = Html
""

typeHtml :: TypeBase Size Freshness -> DocM Html
typeHtml :: TypeBase Size Freshness -> DocM Html
typeHtml TypeBase Size Freshness
t = case TypeBase Size Freshness
t of
  Array Freshness
o Shape Size
shape ScalarTypeBase Size NoMode
et -> do
    shape' <- Shape Size -> DocM Html
prettyShape Shape Size
shape
    et' <- typeHtml $ Scalar $ second (const Nonfresh) et
    pure $ prettyMode o <> shape' <> et'
  Scalar (Prim PrimType
et) -> Html -> DocM Html
forall a.
a -> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html -> DocM Html) -> Html -> DocM Html
forall a b. (a -> b) -> a -> b
$ PrimType -> Html
primTypeHtml PrimType
et
  Scalar (Record Map Name (TypeBase Size Freshness)
fs)
    | Just [TypeBase Size Freshness]
ts <- Map Name (TypeBase Size Freshness)
-> Maybe [TypeBase Size Freshness]
forall a. Map Name a -> Maybe [a]
areTupleFields Map Name (TypeBase Size Freshness)
fs ->
        Html -> Html
parens (Html -> Html) -> ([Html] -> Html) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Html] -> Html
commas ([Html] -> Html)
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
-> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeBase Size Freshness -> DocM Html)
-> [TypeBase Size Freshness]
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TypeBase Size Freshness -> DocM Html
typeHtml [TypeBase Size Freshness]
ts
    | Bool
otherwise ->
        Html -> Html
braces (Html -> Html) -> ([Html] -> Html) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Html] -> Html
commas ([Html] -> Html)
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
-> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, TypeBase Size Freshness) -> DocM Html)
-> [(Name, TypeBase Size Freshness)]
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name, TypeBase Size Freshness) -> DocM Html
ppField (Map Name (TypeBase Size Freshness)
-> [(Name, TypeBase Size Freshness)]
forall k a. Map k a -> [(k, a)]
M.toList Map Name (TypeBase Size Freshness)
fs)
    where
      ppField :: (Name, TypeBase Size Freshness) -> DocM Html
ppField (Name
name, TypeBase Size Freshness
tp) = do
        tp' <- TypeBase Size Freshness -> DocM Html
typeHtml TypeBase Size Freshness
tp
        pure $ toHtml (nameToString name) <> ": " <> tp'
  Scalar (TypeVar Freshness
o QualName VName
et [TypeArg Size]
targs) -> do
    targs' <- (TypeArg Size -> DocM Html)
-> [TypeArg Size]
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TypeArg Size -> DocM Html
typeArgHtml [TypeArg Size]
targs
    et' <- qualNameHtml et
    pure $ prettyMode o <> et' <> mconcat (map (" " <>) targs')
  Scalar (Arrow Freshness
_ PName
pname Diet
d StructType
t1 ResRetType
t2) -> do
    t1' <- TypeBase Size Freshness -> DocM Html
typeHtml (TypeBase Size Freshness -> DocM Html)
-> TypeBase Size Freshness -> DocM Html
forall a b. (a -> b) -> a -> b
$ (NoMode -> Freshness) -> StructType -> TypeBase Size Freshness
forall b c a. (b -> c) -> TypeBase a b -> TypeBase a c
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Freshness -> NoMode -> Freshness
forall a b. a -> b -> a
const Freshness
Nonfresh) StructType
t1
    t2' <- retTypeHtml t2
    case pname of
      Named VName
v -> do
        v' <- VName -> DocM Html
vnameHtml VName
v
        pure $ parens (v' <> ": " <> dietHtml d <> t1') <> " -> " <> t2'
      PName
Unnamed ->
        Html -> DocM Html
forall a.
a -> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html -> DocM Html) -> Html -> DocM Html
forall a b. (a -> b) -> a -> b
$ Diet -> Html
dietHtml Diet
d Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
t1' Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
" -> " Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
t2'
  Scalar (Sum Map Name [TypeBase Size Freshness]
cs) -> [Html] -> Html
pipes ([Html] -> Html)
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
-> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, [TypeBase Size Freshness]) -> DocM Html)
-> [(Name, [TypeBase Size Freshness])]
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name, [TypeBase Size Freshness]) -> DocM Html
ppClause (Map Name [TypeBase Size Freshness]
-> [(Name, [TypeBase Size Freshness])]
forall a. Map Name a -> [(Name, a)]
sortConstrs Map Name [TypeBase Size Freshness]
cs)
    where
      ppClause :: (Name, [TypeBase Size Freshness]) -> DocM Html
ppClause (Name
n, [TypeBase Size Freshness]
ts) = Html -> [Html] -> Html
joinBy Html
" " ([Html] -> Html) -> ([Html] -> [Html]) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Html
ppConstr Name
n Html -> [Html] -> [Html]
forall a. a -> [a] -> [a]
:) ([Html] -> Html)
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
-> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeBase Size Freshness -> DocM Html)
-> [TypeBase Size Freshness]
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TypeBase Size Freshness -> DocM Html
typeHtml [TypeBase Size Freshness]
ts
      ppConstr :: Name -> Html
ppConstr Name
name = Html
"#" Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml (Name -> FilePath
nameToString Name
name)

retTypeHtml :: ResRetType -> DocM Html
retTypeHtml :: ResRetType -> DocM Html
retTypeHtml (RetType [] TypeBase Size Freshness
t) = TypeBase Size Freshness -> DocM Html
typeHtml TypeBase Size Freshness
t
retTypeHtml (RetType [VName]
dims TypeBase Size Freshness
t) = do
  t' <- TypeBase Size Freshness -> DocM Html
typeHtml TypeBase Size Freshness
t
  dims' <- mapM vnameHtml dims
  pure $ "?" <> mconcat (map brackets dims') <> "." <> t'

prettyShape :: Shape Size -> DocM Html
prettyShape :: Shape Size -> DocM Html
prettyShape (Shape [Size]
ds) =
  [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html)
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
-> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Size -> DocM Html)
-> [Size]
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Size -> DocM Html
dimDeclHtml [Size]
ds

typeArgHtml :: TypeArg Size -> DocM Html
typeArgHtml :: TypeArg Size -> DocM Html
typeArgHtml (TypeArgDim Size
d) = Size -> DocM Html
dimDeclHtml Size
d
typeArgHtml (TypeArgType StructType
t) = TypeBase Size Freshness -> DocM Html
typeHtml (TypeBase Size Freshness -> DocM Html)
-> TypeBase Size Freshness -> DocM Html
forall a b. (a -> b) -> a -> b
$ (NoMode -> Freshness) -> StructType -> TypeBase Size Freshness
forall b c a. (b -> c) -> TypeBase a b -> TypeBase a c
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Freshness -> NoMode -> Freshness
forall a b. a -> b -> a
const Freshness
Nonfresh) StructType
t

modParamHtml :: [ModParamBase Info VName] -> DocM Html
modParamHtml :: [ModParamBase Info VName] -> DocM Html
modParamHtml [] = Html -> DocM Html
forall a.
a -> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Html
forall a. Monoid a => a
mempty
modParamHtml (ModParam VName
pname ModTypeExpBase Info VName
psig Info [VName]
_ SrcLoc
_ : [ModParamBase Info VName]
mps) = do
  pname' <- VName -> DocM Html
vnameHtml VName
pname
  psig' <- synopsisModTypeExp psig
  mps' <- modParamHtml mps
  pure $ "(" <> pname' <> ": " <> psig' <> ") -> " <> mps'

synopsisModTypeExp :: ModTypeExpBase Info VName -> DocM Html
synopsisModTypeExp :: ModTypeExpBase Info VName -> DocM Html
synopsisModTypeExp ModTypeExpBase Info VName
e = case ModTypeExpBase Info VName
e of
  ModTypeVar QualName VName
v Info (Map VName VName)
_ SrcLoc
_ -> QualName VName -> DocM Html
qualNameHtml QualName VName
v
  ModTypeParens ModTypeExpBase Info VName
e' SrcLoc
_ -> Html -> Html
parens (Html -> Html) -> DocM Html -> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModTypeExpBase Info VName -> DocM Html
synopsisModTypeExp ModTypeExpBase Info VName
e'
  ModTypeSpecs [SpecBase Info VName]
ss SrcLoc
_ -> Html -> Html
braces (Html -> Html) -> ([Html] -> Html) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Html -> Html
H.table (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"specs") (Html -> Html) -> ([Html] -> Html) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html)
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
-> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SpecBase Info VName -> DocM Html)
-> [SpecBase Info VName]
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM SpecBase Info VName -> DocM Html
synopsisSpec [SpecBase Info VName]
ss
  ModTypeWith ModTypeExpBase Info VName
s (TypeRef QualName VName
v [TypeParamBase VName]
ps TypeExp Size VName
t SrcLoc
_) SrcLoc
_ -> do
    s' <- ModTypeExpBase Info VName -> DocM Html
synopsisModTypeExp ModTypeExpBase Info VName
s
    t' <- typeExpHtml t
    v' <- qualNameHtml v
    ps' <- mconcat <$> mapM (fmap (" " <>) . typeParamHtml) ps
    pure $ s' <> keyword " with " <> v' <> ps' <> " = " <> t'
  ModTypeArrow Maybe VName
Nothing ModTypeExpBase Info VName
e1 ModTypeExpBase Info VName
e2 SrcLoc
_ ->
    (Html -> Html -> Html) -> DocM Html -> DocM Html -> DocM Html
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Html -> Html -> Html
forall {a}. (Semigroup a, IsString a) => a -> a -> a
f (ModTypeExpBase Info VName -> DocM Html
synopsisModTypeExp ModTypeExpBase Info VName
e1) (ModTypeExpBase Info VName -> DocM Html
synopsisModTypeExp ModTypeExpBase Info VName
e2)
    where
      f :: a -> a -> a
f a
e1' a
e2' = a
e1' a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" -> " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
e2'
  ModTypeArrow (Just VName
v) ModTypeExpBase Info VName
e1 ModTypeExpBase Info VName
e2 SrcLoc
_ ->
    do
      name <- VName -> DocM Html
vnameHtml VName
v
      e1' <- synopsisModTypeExp e1
      e2' <- noLink [v] $ synopsisModTypeExp e2
      pure $ "(" <> name <> ": " <> e1' <> ") -> " <> e2'

keyword :: String -> Html
keyword :: FilePath -> Html
keyword = (Html -> Html
H.span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"keyword") (Html -> Html) -> (FilePath -> Html) -> FilePath -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Html
forall a. IsString a => FilePath -> a
fromString

vnameHtml :: VName -> DocM Html
vnameHtml :: VName -> DocM Html
vnameHtml VName
vname = do
  (_, vname_id) <- VName -> DocM (FilePath, FilePath)
vnameId VName
vname
  pure $ H.span ! A.id (fromString vname_id) $ renderName $ baseName vname

-- | The canonical (in-file) anchor ID for a VName, along with the
-- file in which it is defined.
vnameId :: VName -> DocM (FilePath, String)
vnameId :: VName -> DocM (FilePath, FilePath)
vnameId VName
vname = do
  current <- (Context -> FilePath)
-> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> FilePath
ctxCurrent
  asks $ fromMaybe (current, show (baseTag vname)) . M.lookup vname . ctxFileMap

vnameDescDef :: VName -> IndexWhat -> DocM Html
vnameDescDef :: VName -> IndexWhat -> DocM Html
vnameDescDef VName
v IndexWhat
what = do
  VName -> IndexWhat -> DocM ()
document VName
v IndexWhat
what
  (_, v_id) <- VName -> DocM (FilePath, FilePath)
vnameId VName
v
  pure $ H.a ! A.id (fromString v_id) $ renderName (baseName v)

vnameSynopsisRef :: VName -> DocM Html
vnameSynopsisRef :: VName -> DocM Html
vnameSynopsisRef VName
v = do
  (_, v_id) <- VName -> DocM (FilePath, FilePath)
vnameId VName
v
  pure
    $ H.a
      ! A.class_ "synopsis_link"
      ! A.href (fromString ("#" <> "synopsis:" <> v_id))
    $ "↑"

synopsisSpec :: SpecBase Info VName -> DocM Html
synopsisSpec :: SpecBase Info VName -> DocM Html
synopsisSpec SpecBase Info VName
spec = case SpecBase Info VName
spec of
  TypeAbbrSpec TypeBindBase Info VName
tpsig -> do
    def <- VName -> DocM Html
vnameSynopsisDef (VName -> DocM Html) -> VName -> DocM Html
forall a b. (a -> b) -> a -> b
$ TypeBindBase Info VName -> VName
forall (f :: * -> *) vn. TypeBindBase f vn -> vn
typeAlias TypeBindBase Info VName
tpsig
    fullRow <$> typeBindHtml def tpsig
  TypeSpec Liftedness
l VName
name [TypeParamBase VName]
ps Maybe DocComment
_ SrcLoc
_ -> do
    name' <- VName -> DocM Html
vnameSynopsisDef VName
name
    ps' <- mconcat <$> mapM (fmap (" " <>) . typeParamHtml) ps
    pure $ fullRow $ keyword l' <> name' <> ps'
    where
      l' :: FilePath
l' = case Liftedness
l of
        Liftedness
Unlifted -> FilePath
"type "
        Liftedness
SizeLifted -> FilePath
"type~ "
        Liftedness
Lifted -> FilePath
"type^ "
  ValSpec VName
name [TypeParamBase VName]
tparams TypeExp Size VName
rettype Info StructType
_ Maybe DocComment
_ SrcLoc
_ -> do
    tparams' <- (TypeParamBase VName -> DocM Html)
-> [TypeParamBase VName]
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TypeParamBase VName -> DocM Html
typeParamHtml [TypeParamBase VName]
tparams
    rettype' <- noLink (map typeParamName tparams) $ typeExpHtml rettype
    name' <- vnameSynopsisDef name
    pure $
      specRow
        (keyword "val " <> name')
        (mconcat (map (" " <>) tparams') <> ": ")
        rettype'
  ModSpec VName
name ModTypeExpBase Info VName
sig Maybe DocComment
_ SrcLoc
_ -> do
    name' <- VName -> DocM Html
vnameSynopsisDef VName
name
    specRow (keyword "module " <> name') ": " <$> synopsisModTypeExp sig
  IncludeSpec ModTypeExpBase Info VName
e SrcLoc
_ -> Html -> Html
fullRow (Html -> Html) -> (Html -> Html) -> Html -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Html
keyword FilePath
"include " Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<>) (Html -> Html) -> DocM Html -> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModTypeExpBase Info VName -> DocM Html
synopsisModTypeExp ModTypeExpBase Info VName
e

typeExpHtml :: TypeExp Exp VName -> DocM Html
typeExpHtml :: TypeExp Size VName -> DocM Html
typeExpHtml TypeExp Size VName
e = case TypeExp Size VName
e of
  TEStar TypeExp Size VName
t SrcLoc
_ -> (Html
"*" Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<>) (Html -> Html) -> DocM Html -> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeExp Size VName -> DocM Html
typeExpHtml TypeExp Size VName
t
  TEArray SizeExp Size
d TypeExp Size VName
at SrcLoc
_ -> do
    at' <- TypeExp Size VName -> DocM Html
typeExpHtml TypeExp Size VName
at
    d' <- dimExpHtml d
    pure $ d' <> at'
  TETuple [TypeExp Size VName]
ts SrcLoc
_ -> Html -> Html
parens (Html -> Html) -> ([Html] -> Html) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Html] -> Html
commas ([Html] -> Html)
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
-> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeExp Size VName -> DocM Html)
-> [TypeExp Size VName]
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TypeExp Size VName -> DocM Html
typeExpHtml [TypeExp Size VName]
ts
  TERecord [(L Name, TypeExp Size VName)]
fs SrcLoc
_ -> Html -> Html
braces (Html -> Html) -> ([Html] -> Html) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Html] -> Html
commas ([Html] -> Html)
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
-> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((L Name, TypeExp Size VName) -> DocM Html)
-> [(L Name, TypeExp Size VName)]
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (L Name, TypeExp Size VName) -> DocM Html
ppField [(L Name, TypeExp Size VName)]
fs
    where
      ppField :: (L Name, TypeExp Size VName) -> DocM Html
ppField (L Loc
_ Name
name, TypeExp Size VName
t) = do
        t' <- TypeExp Size VName -> DocM Html
typeExpHtml TypeExp Size VName
t
        pure $ toHtml (nameToString name) <> ": " <> t'
  TEVar QualName VName
name SrcLoc
_ -> QualName VName -> DocM Html
qualNameHtml QualName VName
name
  TEParens TypeExp Size VName
te SrcLoc
_ -> Html -> Html
parens (Html -> Html) -> DocM Html -> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeExp Size VName -> DocM Html
typeExpHtml TypeExp Size VName
te
  TEApply TypeExp Size VName
t TypeArgExp Size VName
arg SrcLoc
_ -> do
    t' <- TypeExp Size VName -> DocM Html
typeExpHtml TypeExp Size VName
t
    arg' <- typeArgExpHtml arg
    pure $ t' <> " " <> arg'
  TEArrow Maybe VName
pname TypeExp Size VName
t1 TypeExp Size VName
t2 SrcLoc
_ -> do
    t1' <- case TypeExp Size VName
t1 of
      TEArrow {} -> Html -> Html
parens (Html -> Html) -> DocM Html -> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeExp Size VName -> DocM Html
typeExpHtml TypeExp Size VName
t1
      TypeExp Size VName
_ -> TypeExp Size VName -> DocM Html
typeExpHtml TypeExp Size VName
t1
    t2' <- typeExpHtml t2
    case pname of
      Just VName
v -> do
        v' <- VName -> DocM Html
vnameHtml VName
v
        pure $ parens (v' <> ": " <> t1') <> " -> " <> t2'
      Maybe VName
Nothing ->
        Html -> DocM Html
forall a.
a -> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html -> DocM Html) -> Html -> DocM Html
forall a b. (a -> b) -> a -> b
$ Html
t1' Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
" -> " Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
t2'
  TESum [(Name, [TypeExp Size VName])]
cs SrcLoc
_ -> [Html] -> Html
pipes ([Html] -> Html)
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
-> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, [TypeExp Size VName]) -> DocM Html)
-> [(Name, [TypeExp Size VName])]
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name, [TypeExp Size VName]) -> DocM Html
ppClause [(Name, [TypeExp Size VName])]
cs
    where
      ppClause :: (Name, [TypeExp Size VName]) -> DocM Html
ppClause (Name
n, [TypeExp Size VName]
ts) = Html -> [Html] -> Html
joinBy Html
" " ([Html] -> Html) -> ([Html] -> [Html]) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Html
ppConstr Name
n Html -> [Html] -> [Html]
forall a. a -> [a] -> [a]
:) ([Html] -> Html)
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
-> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeExp Size VName -> DocM Html)
-> [TypeExp Size VName]
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TypeExp Size VName -> DocM Html
typeExpHtml [TypeExp Size VName]
ts
      ppConstr :: Name -> Html
ppConstr Name
name = Html
"#" Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml (Name -> FilePath
nameToString Name
name)
  TEDim [VName]
dims TypeExp Size VName
t SrcLoc
_ -> do
    t' <- TypeExp Size VName -> DocM Html
typeExpHtml TypeExp Size VName
t
    pure $ "?" <> mconcat (map (brackets . renderName . baseName) dims) <> "." <> t'

qualNameHtml :: QualName VName -> DocM Html
qualNameHtml :: QualName VName -> DocM Html
qualNameHtml (QualName [VName]
names VName
vname) =
  if VName -> Bool
isIntrinsic VName
vname
    then Html -> DocM Html
forall a.
a -> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html -> DocM Html) -> Html -> DocM Html
forall a b. (a -> b) -> a -> b
$ Name -> Html
renderName (Name -> Html) -> Name -> Html
forall a b. (a -> b) -> a -> b
$ VName -> Name
baseName VName
vname
    else Maybe FilePath -> Html
f (Maybe FilePath -> Html)
-> ReaderT
     Context (WriterT Documented (Writer Warnings)) (Maybe FilePath)
-> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  Context (WriterT Documented (Writer Warnings)) (Maybe FilePath)
ref
  where
    prefix :: Html
    prefix :: Html
prefix = (VName -> Html) -> [VName] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
".") (Html -> Html) -> (VName -> Html) -> VName -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Html
renderName (Name -> Html) -> (VName -> Name) -> VName -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> Name
baseName) [VName]
names
    f :: Maybe FilePath -> Html
f (Just FilePath
s) = Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (FilePath -> AttributeValue
forall a. IsString a => FilePath -> a
fromString FilePath
s) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
prefix Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Name -> Html
renderName (VName -> Name
baseName VName
vname)
    f Maybe FilePath
Nothing = Html
prefix Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Name -> Html
renderName (VName -> Name
baseName VName
vname)

    ref :: ReaderT
  Context (WriterT Documented (Writer Warnings)) (Maybe FilePath)
ref = do
      boring <- (Context -> Bool)
-> ReaderT Context (WriterT Documented (Writer Warnings)) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Context -> Bool)
 -> ReaderT Context (WriterT Documented (Writer Warnings)) Bool)
-> (Context -> Bool)
-> ReaderT Context (WriterT Documented (Writer Warnings)) Bool
forall a b. (a -> b) -> a -> b
$ VName -> NoLink -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member VName
vname (NoLink -> Bool) -> (Context -> NoLink) -> Context -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> NoLink
ctxNoLink
      if boring
        then pure Nothing
        else Just <$> vnameLink vname

-- | The link for a VName.
vnameLink :: VName -> DocM String
vnameLink :: VName
-> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
vnameLink VName
vname = do
  current <- (Context -> FilePath)
-> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> FilePath
ctxCurrent
  (file, tag) <- vnameId vname
  pure $ vnameLink' tag current file

vnameLink' :: String -> FilePath -> FilePath -> String
vnameLink' :: FilePath -> FilePath -> FilePath -> FilePath
vnameLink' FilePath
tag FilePath
current FilePath
file =
  if FilePath
file FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
current
    then FilePath
"#" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tag
    else FilePath -> FilePath -> FilePath
relativise FilePath
file FilePath
current FilePath -> FilePath -> FilePath
-<.> FilePath
".html#" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tag

paramHtml :: Pat ParamType -> DocM Html
paramHtml :: PatBase Info VName ParamType -> DocM Html
paramHtml PatBase Info VName ParamType
pat = do
  let (PName
pat_param, Diet
d, StructType
t) = PatBase Info VName ParamType -> (PName, Diet, StructType)
forall d. Pat (TypeBase d Diet) -> (PName, Diet, TypeBase d NoMode)
patternParam PatBase Info VName ParamType
pat
  t' <- TypeBase Size Freshness -> DocM Html
typeHtml (TypeBase Size Freshness -> DocM Html)
-> TypeBase Size Freshness -> DocM Html
forall a b. (a -> b) -> a -> b
$ (NoMode -> Freshness) -> StructType -> TypeBase Size Freshness
forall b c a. (b -> c) -> TypeBase a b -> TypeBase a c
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Freshness -> NoMode -> Freshness
forall a b. a -> b -> a
const Freshness
Nonfresh) StructType
t
  case pat_param of
    Named VName
v -> do
      v' <- VName -> DocM Html
vnameHtml VName
v
      pure $ parens $ v' <> ": " <> dietHtml d <> t'
    PName
Unnamed -> Html -> DocM Html
forall a.
a -> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Html
t'

dimDeclHtml :: Size -> DocM Html
dimDeclHtml :: Size -> DocM Html
dimDeclHtml = Html -> DocM Html
forall a.
a -> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html -> DocM Html) -> (Size -> Html) -> Size -> DocM Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Html
brackets (Html -> Html) -> (Size -> Html) -> Size -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml (FilePath -> Html) -> (Size -> FilePath) -> Size -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Size -> FilePath
forall a. Pretty a => a -> FilePath
prettyString

dimExpHtml :: SizeExp Exp -> DocM Html
dimExpHtml :: SizeExp Size -> DocM Html
dimExpHtml (SizeExpAny SrcLoc
_) = Html -> DocM Html
forall a.
a -> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html -> DocM Html) -> Html -> DocM Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
brackets Html
forall a. Monoid a => a
mempty
dimExpHtml (SizeExp Size
e SrcLoc
_) = Html -> DocM Html
forall a.
a -> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html -> DocM Html) -> Html -> DocM Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
brackets (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
$ Size -> FilePath
forall a. Pretty a => a -> FilePath
prettyString Size
e

typeArgExpHtml :: TypeArgExp Exp VName -> DocM Html
typeArgExpHtml :: TypeArgExp Size VName -> DocM Html
typeArgExpHtml (TypeArgExpSize SizeExp Size
d) = SizeExp Size -> DocM Html
dimExpHtml SizeExp Size
d
typeArgExpHtml (TypeArgExpType TypeExp Size VName
d) = TypeExp Size VName -> DocM Html
typeExpHtml TypeExp Size VName
d

typeParamHtml :: TypeParam -> DocM Html
typeParamHtml :: TypeParamBase VName -> DocM Html
typeParamHtml (TypeParamDim VName
name SrcLoc
_) = do
  name' <- VName -> DocM Html
vnameHtml VName
name
  pure $ brackets name'
typeParamHtml (TypeParamType Liftedness
l VName
name SrcLoc
_) = do
  name' <- VName -> DocM Html
vnameHtml VName
name
  pure $ "'" <> fromString (prettyString l) <> name'

typeAbbrevHtml :: Liftedness -> Html -> [TypeParam] -> DocM Html
typeAbbrevHtml :: Liftedness -> Html -> [TypeParamBase VName] -> DocM Html
typeAbbrevHtml Liftedness
l Html
name [TypeParamBase VName]
params = do
  params' <- [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html)
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
-> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeParamBase VName -> DocM Html)
-> [TypeParamBase VName]
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Html -> Html) -> DocM Html -> DocM Html
forall a b.
(a -> b)
-> ReaderT Context (WriterT Documented (Writer Warnings)) a
-> ReaderT Context (WriterT Documented (Writer Warnings)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Html
" " Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<>) (DocM Html -> DocM Html)
-> (TypeParamBase VName -> DocM Html)
-> TypeParamBase VName
-> DocM Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeParamBase VName -> DocM Html
typeParamHtml) [TypeParamBase VName]
params
  pure $ what <> name <> params'
  where
    what :: Html
what = FilePath -> Html
keyword (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$ FilePath
"type" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Liftedness -> FilePath
forall a. Pretty a => a -> FilePath
prettyString Liftedness
l FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" "

docHtml :: Maybe DocComment -> DocM Html
docHtml :: Maybe DocComment -> DocM Html
docHtml (Just (DocComment Text
doc SrcLoc
loc)) =
  Text -> Html
H.preEscapedText
    (Text -> Html) -> (FilePath -> Text) -> FilePath -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CMarkOption] -> [CMarkExtension] -> Text -> Text
GFM.commonmarkToHtml [] [CMarkExtension
GFM.extAutolink]
    (Text -> Text) -> (FilePath -> Text) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack
    (FilePath -> Html)
-> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
-> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Loc
-> FilePath
-> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
identifierLinks (SrcLoc -> Loc
forall a. Located a => a -> Loc
locOf SrcLoc
loc) (Text -> FilePath
T.unpack Text
doc)
docHtml Maybe DocComment
Nothing = Html -> DocM Html
forall a.
a -> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Html
forall a. Monoid a => a
mempty

identifierLinks :: Loc -> String -> DocM String
identifierLinks :: Loc
-> FilePath
-> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
identifierLinks Loc
_ [] = FilePath
-> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
forall a.
a -> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
identifierLinks Loc
loc FilePath
s
  | Just ((FilePath
name, FilePath
namespace, Maybe FilePath
file), FilePath
s') <- FilePath -> Maybe ((FilePath, FilePath, Maybe FilePath), FilePath)
identifierReference FilePath
s = do
      let proceed :: FilePath
-> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
proceed FilePath
x = (FilePath
x FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>) (FilePath -> FilePath)
-> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
-> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Loc
-> FilePath
-> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
identifierLinks Loc
loc FilePath
s'
          unknown :: ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
unknown = FilePath
-> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
proceed (FilePath
 -> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath)
-> FilePath
-> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"`" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
name FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"`"
      case FilePath -> Maybe Namespace
forall {a}. (Eq a, IsString a) => a -> Maybe Namespace
knownNamespace FilePath
namespace of
        Just Namespace
namespace' -> do
          maybe_v <- (Namespace, FilePath, Maybe FilePath) -> DocM (Maybe VName)
lookupName (Namespace
namespace', FilePath
name, Maybe FilePath
file)
          case maybe_v of
            Maybe VName
Nothing -> do
              Loc -> Doc () -> DocM ()
warn Loc
loc (Doc () -> DocM ()) -> Doc () -> DocM ()
forall a b. (a -> b) -> a -> b
$
                Doc ()
"Identifier '"
                  Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> FilePath -> Doc ()
forall a. IsString a => FilePath -> a
fromString FilePath
name
                  Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"' not found in namespace '"
                  Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> FilePath -> Doc ()
forall a. IsString a => FilePath -> a
fromString FilePath
namespace
                  Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"'"
                  Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> FilePath -> Doc ()
forall a. IsString a => FilePath -> a
fromString (FilePath -> (FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" (FilePath
" in file " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>) Maybe FilePath
file)
                  Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"."
              ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
unknown
            Just VName
v' -> do
              link <- VName
-> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
vnameLink VName
v'
              proceed $ "[`" <> name <> "`](" <> link <> ")"
        Maybe Namespace
_ -> do
          Loc -> Doc () -> DocM ()
warn Loc
loc (Doc () -> DocM ()) -> Doc () -> DocM ()
forall a b. (a -> b) -> a -> b
$ Doc ()
"Unknown namespace '" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> FilePath -> Doc ()
forall a. IsString a => FilePath -> a
fromString FilePath
namespace Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"'."
          ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
unknown
  where
    knownNamespace :: a -> Maybe Namespace
knownNamespace a
"term" = Namespace -> Maybe Namespace
forall a. a -> Maybe a
Just Namespace
Term
    knownNamespace a
"mtype" = Namespace -> Maybe Namespace
forall a. a -> Maybe a
Just Namespace
Signature
    knownNamespace a
"type" = Namespace -> Maybe Namespace
forall a. a -> Maybe a
Just Namespace
Type
    knownNamespace a
_ = Maybe Namespace
forall a. Maybe a
Nothing
identifierLinks Loc
loc (Char
c : FilePath
s') = (Char
c Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:) (FilePath -> FilePath)
-> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
-> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Loc
-> FilePath
-> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
identifierLinks Loc
loc FilePath
s'

lookupName :: (Namespace, String, Maybe FilePath) -> DocM (Maybe VName)
lookupName :: (Namespace, FilePath, Maybe FilePath) -> DocM (Maybe VName)
lookupName (Namespace
namespace, FilePath
name, Maybe FilePath
file) = do
  current <- (Context -> FilePath)
-> ReaderT Context (WriterT Documented (Writer Warnings)) FilePath
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> FilePath
ctxCurrent
  let file' = ImportName -> FilePath -> ImportName
mkImportFrom (FilePath -> ImportName
mkInitialImport FilePath
current) (FilePath -> ImportName) -> Maybe FilePath -> Maybe ImportName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FilePath
file
  env <- lookupEnvForFile file'
  case M.lookup (namespace, nameFromString name) . envNameMap =<< env of
    Maybe (QualName VName)
Nothing -> Maybe VName -> DocM (Maybe VName)
forall a.
a -> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe VName
forall a. Maybe a
Nothing
    Just QualName VName
qn -> Maybe VName -> DocM (Maybe VName)
forall a.
a -> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe VName -> DocM (Maybe VName))
-> Maybe VName -> DocM (Maybe VName)
forall a b. (a -> b) -> a -> b
$ VName -> Maybe VName
forall a. a -> Maybe a
Just (VName -> Maybe VName) -> VName -> Maybe VName
forall a b. (a -> b) -> a -> b
$ QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
qn

lookupEnvForFile :: Maybe ImportName -> DocM (Maybe Env)
lookupEnvForFile :: Maybe ImportName -> DocM (Maybe Env)
lookupEnvForFile Maybe ImportName
Nothing = (Context -> Maybe Env) -> DocM (Maybe Env)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Context -> Maybe Env) -> DocM (Maybe Env))
-> (Context -> Maybe Env) -> DocM (Maybe Env)
forall a b. (a -> b) -> a -> b
$ Env -> Maybe Env
forall a. a -> Maybe a
Just (Env -> Maybe Env) -> (Context -> Env) -> Context -> Maybe Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileModule -> Env
fileEnv (FileModule -> Env) -> (Context -> FileModule) -> Context -> Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> FileModule
ctxFileMod
lookupEnvForFile (Just ImportName
file) = (Context -> Maybe Env) -> DocM (Maybe Env)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Context -> Maybe Env) -> DocM (Maybe Env))
-> (Context -> Maybe Env) -> DocM (Maybe Env)
forall a b. (a -> b) -> a -> b
$ (FileModule -> Env) -> Maybe FileModule -> Maybe Env
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileModule -> Env
fileEnv (Maybe FileModule -> Maybe Env)
-> (Context -> Maybe FileModule) -> Context -> Maybe Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportName -> Imports -> Maybe FileModule
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ImportName
file (Imports -> Maybe FileModule)
-> (Context -> Imports) -> Context -> Maybe FileModule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Imports
ctxImports

describeGeneric ::
  VName ->
  IndexWhat ->
  Maybe DocComment ->
  (Html -> DocM Html) ->
  DocM Html
describeGeneric :: VName
-> IndexWhat
-> Maybe DocComment
-> (Html -> DocM Html)
-> DocM Html
describeGeneric VName
name IndexWhat
what Maybe DocComment
doc Html -> DocM Html
f = do
  name' <- Html -> Html
H.span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"decl_name" (Html -> Html) -> DocM Html -> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> IndexWhat -> DocM Html
vnameDescDef VName
name IndexWhat
what
  decl_type <- f name'
  doc' <- docHtml doc
  ref <- vnameSynopsisRef name
  let decl_doc = Html -> Html
H.dd (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"desc_doc" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
doc'
      decl_header = (Html -> Html
H.dt (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"desc_header") (Html
ref Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
decl_type)
  pure $ decl_header <> decl_doc

describeGenericMod ::
  VName ->
  IndexWhat ->
  ModTypeExp ->
  Maybe DocComment ->
  (Html -> DocM Html) ->
  DocM Html
describeGenericMod :: VName
-> IndexWhat
-> ModTypeExpBase Info VName
-> Maybe DocComment
-> (Html -> DocM Html)
-> DocM Html
describeGenericMod VName
name IndexWhat
what ModTypeExpBase Info VName
se Maybe DocComment
doc Html -> DocM Html
f = do
  name' <- Html -> Html
H.span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"decl_name" (Html -> Html) -> DocM Html -> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> IndexWhat -> DocM Html
vnameDescDef VName
name IndexWhat
what

  decl_type <- f name'

  doc' <- case se of
    ModTypeSpecs [SpecBase Info VName]
specs SrcLoc
_ -> Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
(<>) (Html -> Html -> Html)
-> DocM Html
-> ReaderT
     Context (WriterT Documented (Writer Warnings)) (Html -> Html)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe DocComment -> DocM Html
docHtml Maybe DocComment
doc ReaderT
  Context (WriterT Documented (Writer Warnings)) (Html -> Html)
-> DocM Html -> DocM Html
forall a b.
ReaderT Context (WriterT Documented (Writer Warnings)) (a -> b)
-> ReaderT Context (WriterT Documented (Writer Warnings)) a
-> ReaderT Context (WriterT Documented (Writer Warnings)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [SpecBase Info VName] -> DocM Html
describeSpecs [SpecBase Info VName]
specs
    ModTypeExpBase Info VName
_ -> Maybe DocComment -> DocM Html
docHtml Maybe DocComment
doc

  ref <- vnameSynopsisRef name

  let decl_doc = Html -> Html
H.dd (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"desc_doc" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
doc'
      decl_header = (Html -> Html
H.dt (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"desc_header") (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
ref Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
decl_type
  pure $ decl_header <> decl_doc

describeDecs :: [Dec] -> DocM Html
describeDecs :: [Dec] -> DocM Html
describeDecs [Dec]
decs = do
  visible <- (Context -> NoLink)
-> ReaderT Context (WriterT Documented (Writer Warnings)) NoLink
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> NoLink
ctxVisibleMTys
  H.dl . mconcat
    <$> mapM
      (fmap $ H.div ! A.class_ "decl_description")
      (mapMaybe (describeDec visible) decs)

describeDec :: S.Set VName -> Dec -> Maybe (DocM Html)
describeDec :: NoLink -> Dec -> Maybe (DocM Html)
describeDec NoLink
_ (ValDec ValBindBase Info VName
vb) = DocM Html -> Maybe (DocM Html)
forall a. a -> Maybe a
Just (DocM Html -> Maybe (DocM Html)) -> DocM Html -> Maybe (DocM Html)
forall a b. (a -> b) -> a -> b
$
  VName
-> IndexWhat
-> Maybe DocComment
-> (Html -> DocM Html)
-> DocM Html
describeGeneric (ValBindBase Info VName -> VName
forall (f :: * -> *) vn. ValBindBase f vn -> vn
valBindName ValBindBase Info VName
vb) (ValBindBase Info VName -> IndexWhat
valBindWhat ValBindBase Info VName
vb) (ValBindBase Info VName -> Maybe DocComment
forall (f :: * -> *) vn. ValBindBase f vn -> Maybe DocComment
valBindDoc ValBindBase Info VName
vb) ((Html -> DocM Html) -> DocM Html)
-> (Html -> DocM Html) -> DocM Html
forall a b. (a -> b) -> a -> b
$ \Html
name -> do
    (lhs, mhs, rhs) <- Html -> ValBindBase Info VName -> DocM (Html, Html, Html)
valBindHtml Html
name ValBindBase Info VName
vb
    pure $ lhs <> mhs <> ": " <> rhs
describeDec NoLink
_ (TypeDec TypeBindBase Info VName
vb) =
  DocM Html -> Maybe (DocM Html)
forall a. a -> Maybe a
Just (DocM Html -> Maybe (DocM Html)) -> DocM Html -> Maybe (DocM Html)
forall a b. (a -> b) -> a -> b
$
    VName
-> IndexWhat
-> Maybe DocComment
-> (Html -> DocM Html)
-> DocM Html
describeGeneric (TypeBindBase Info VName -> VName
forall (f :: * -> *) vn. TypeBindBase f vn -> vn
typeAlias TypeBindBase Info VName
vb) IndexWhat
IndexType (TypeBindBase Info VName -> Maybe DocComment
forall (f :: * -> *) vn. TypeBindBase f vn -> Maybe DocComment
typeDoc TypeBindBase Info VName
vb) (Html -> TypeBindBase Info VName -> DocM Html
`typeBindHtml` TypeBindBase Info VName
vb)
describeDec NoLink
_ (ModTypeDec (ModTypeBind VName
name ModTypeExpBase Info VName
se Maybe DocComment
doc SrcLoc
_)) = DocM Html -> Maybe (DocM Html)
forall a. a -> Maybe a
Just (DocM Html -> Maybe (DocM Html)) -> DocM Html -> Maybe (DocM Html)
forall a b. (a -> b) -> a -> b
$
  VName
-> IndexWhat
-> ModTypeExpBase Info VName
-> Maybe DocComment
-> (Html -> DocM Html)
-> DocM Html
describeGenericMod VName
name IndexWhat
IndexModuleType ModTypeExpBase Info VName
se Maybe DocComment
doc ((Html -> DocM Html) -> DocM Html)
-> (Html -> DocM Html) -> DocM Html
forall a b. (a -> b) -> a -> b
$ \Html
name' ->
    Html -> DocM Html
forall a.
a -> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html -> DocM Html) -> Html -> DocM Html
forall a b. (a -> b) -> a -> b
$ FilePath -> Html
keyword FilePath
"module type " Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
name'
describeDec NoLink
_ (ModDec ModBindBase Info VName
mb) = DocM Html -> Maybe (DocM Html)
forall a. a -> Maybe a
Just (DocM Html -> Maybe (DocM Html)) -> DocM Html -> Maybe (DocM Html)
forall a b. (a -> b) -> a -> b
$
  VName
-> IndexWhat
-> Maybe DocComment
-> (Html -> DocM Html)
-> DocM Html
describeGeneric (ModBindBase Info VName -> VName
forall (f :: * -> *) vn. ModBindBase f vn -> vn
modName ModBindBase Info VName
mb) IndexWhat
IndexModule (ModBindBase Info VName -> Maybe DocComment
forall (f :: * -> *) vn. ModBindBase f vn -> Maybe DocComment
modDoc ModBindBase Info VName
mb) ((Html -> DocM Html) -> DocM Html)
-> (Html -> DocM Html) -> DocM Html
forall a b. (a -> b) -> a -> b
$ \Html
name' ->
    Html -> DocM Html
forall a.
a -> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html -> DocM Html) -> Html -> DocM Html
forall a b. (a -> b) -> a -> b
$ FilePath -> Html
keyword FilePath
"module " Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
name'
describeDec NoLink
_ OpenDec {} = Maybe (DocM Html)
forall a. Maybe a
Nothing
describeDec NoLink
visible (LocalDec (ModTypeDec (ModTypeBind VName
name ModTypeExpBase Info VName
se Maybe DocComment
doc SrcLoc
_)) SrcLoc
_)
  | VName
name VName -> NoLink -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` NoLink
visible = DocM Html -> Maybe (DocM Html)
forall a. a -> Maybe a
Just (DocM Html -> Maybe (DocM Html)) -> DocM Html -> Maybe (DocM Html)
forall a b. (a -> b) -> a -> b
$
      VName
-> IndexWhat
-> ModTypeExpBase Info VName
-> Maybe DocComment
-> (Html -> DocM Html)
-> DocM Html
describeGenericMod VName
name IndexWhat
IndexModuleType ModTypeExpBase Info VName
se Maybe DocComment
doc ((Html -> DocM Html) -> DocM Html)
-> (Html -> DocM Html) -> DocM Html
forall a b. (a -> b) -> a -> b
$ \Html
name' ->
        Html -> DocM Html
forall a.
a -> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html -> DocM Html) -> Html -> DocM Html
forall a b. (a -> b) -> a -> b
$ FilePath -> Html
keyword FilePath
"local module type " Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
name'
describeDec NoLink
_ LocalDec {} = Maybe (DocM Html)
forall a. Maybe a
Nothing
describeDec NoLink
_ ImportDec {} = Maybe (DocM Html)
forall a. Maybe a
Nothing

valBindWhat :: ValBind -> IndexWhat
valBindWhat :: ValBindBase Info VName -> IndexWhat
valBindWhat ValBindBase Info VName
vb
  | [PatBase Info VName ParamType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ValBindBase Info VName -> [PatBase Info VName ParamType]
forall (f :: * -> *) vn.
ValBindBase f vn -> [PatBase f vn ParamType]
valBindParams ValBindBase Info VName
vb),
    RetType [VName]
_ TypeBase Size Freshness
t <- Info ResRetType -> ResRetType
forall a. Info a -> a
unInfo (Info ResRetType -> ResRetType) -> Info ResRetType -> ResRetType
forall a b. (a -> b) -> a -> b
$ ValBindBase Info VName -> Info ResRetType
forall (f :: * -> *) vn. ValBindBase f vn -> f ResRetType
valBindRetType ValBindBase Info VName
vb,
    TypeBase Size Freshness -> Bool
forall dim o. TypeBase dim o -> Bool
orderZero TypeBase Size Freshness
t =
      IndexWhat
IndexValue
  | Bool
otherwise =
      IndexWhat
IndexFunction

describeSpecs :: [Spec] -> DocM Html
describeSpecs :: [SpecBase Info VName] -> DocM Html
describeSpecs [SpecBase Info VName]
specs =
  Html -> Html
H.dl (Html -> Html) -> ([Html] -> Html) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html)
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
-> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SpecBase Info VName -> DocM Html)
-> [SpecBase Info VName]
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM SpecBase Info VName -> DocM Html
describeSpec [SpecBase Info VName]
specs

describeSpec :: Spec -> DocM Html
describeSpec :: SpecBase Info VName -> DocM Html
describeSpec (ValSpec VName
name [TypeParamBase VName]
tparams TypeExp Size VName
t Info StructType
_ Maybe DocComment
doc SrcLoc
_) =
  VName
-> IndexWhat
-> Maybe DocComment
-> (Html -> DocM Html)
-> DocM Html
describeGeneric VName
name IndexWhat
what Maybe DocComment
doc ((Html -> DocM Html) -> DocM Html)
-> (Html -> DocM Html) -> DocM Html
forall a b. (a -> b) -> a -> b
$ \Html
name' -> do
    tparams' <- [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html)
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
-> DocM Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeParamBase VName -> DocM Html)
-> [TypeParamBase VName]
-> ReaderT Context (WriterT Documented (Writer Warnings)) [Html]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Html -> Html) -> DocM Html -> DocM Html
forall a b.
(a -> b)
-> ReaderT Context (WriterT Documented (Writer Warnings)) a
-> ReaderT Context (WriterT Documented (Writer Warnings)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Html
" " Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<>) (DocM Html -> DocM Html)
-> (TypeParamBase VName -> DocM Html)
-> TypeParamBase VName
-> DocM Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeParamBase VName -> DocM Html
typeParamHtml) [TypeParamBase VName]
tparams
    t' <- noLink (map typeParamName tparams) $ typeExpHtml t
    pure $ keyword "val " <> name' <> tparams' <> ": " <> t'
  where
    what :: IndexWhat
what =
      case TypeExp Size VName
t of
        TEArrow {} -> IndexWhat
IndexFunction
        TypeExp Size VName
_ -> IndexWhat
IndexValue
describeSpec (TypeAbbrSpec TypeBindBase Info VName
vb) =
  VName
-> IndexWhat
-> Maybe DocComment
-> (Html -> DocM Html)
-> DocM Html
describeGeneric (TypeBindBase Info VName -> VName
forall (f :: * -> *) vn. TypeBindBase f vn -> vn
typeAlias TypeBindBase Info VName
vb) IndexWhat
IndexType (TypeBindBase Info VName -> Maybe DocComment
forall (f :: * -> *) vn. TypeBindBase f vn -> Maybe DocComment
typeDoc TypeBindBase Info VName
vb) (Html -> TypeBindBase Info VName -> DocM Html
`typeBindHtml` TypeBindBase Info VName
vb)
describeSpec (TypeSpec Liftedness
l VName
name [TypeParamBase VName]
tparams Maybe DocComment
doc SrcLoc
_) =
  VName
-> IndexWhat
-> Maybe DocComment
-> (Html -> DocM Html)
-> DocM Html
describeGeneric VName
name IndexWhat
IndexType Maybe DocComment
doc ((Html -> DocM Html) -> DocM Html)
-> (Html -> DocM Html) -> DocM Html
forall a b. (a -> b) -> a -> b
$ \Html
name' -> Liftedness -> Html -> [TypeParamBase VName] -> DocM Html
typeAbbrevHtml Liftedness
l Html
name' [TypeParamBase VName]
tparams
describeSpec (ModSpec VName
name ModTypeExpBase Info VName
se Maybe DocComment
doc SrcLoc
_) =
  VName
-> IndexWhat
-> ModTypeExpBase Info VName
-> Maybe DocComment
-> (Html -> DocM Html)
-> DocM Html
describeGenericMod VName
name IndexWhat
IndexModule ModTypeExpBase Info VName
se Maybe DocComment
doc ((Html -> DocM Html) -> DocM Html)
-> (Html -> DocM Html) -> DocM Html
forall a b. (a -> b) -> a -> b
$ \Html
name' ->
    case ModTypeExpBase Info VName
se of
      ModTypeSpecs {} -> Html -> DocM Html
forall a.
a -> ReaderT Context (WriterT Documented (Writer Warnings)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html -> DocM Html) -> Html -> DocM Html
forall a b. (a -> b) -> a -> b
$ FilePath -> Html
keyword FilePath
"module " Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
name'
      ModTypeExpBase Info VName
_ -> do
        se' <- ModTypeExpBase Info VName -> DocM Html
synopsisModTypeExp ModTypeExpBase Info VName
se
        pure $ keyword "module " <> name' <> ": " <> se'
describeSpec (IncludeSpec ModTypeExpBase Info VName
sig SrcLoc
_) = do
  sig' <- ModTypeExpBase Info VName -> DocM Html
synopsisModTypeExp ModTypeExpBase Info VName
sig
  doc' <- docHtml Nothing
  let decl_header =
        (Html -> Html
H.dt (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"desc_header") (Html -> Html) -> Html -> Html
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
A.class_ AttributeValue
"synopsis_link") Html
forall a. Monoid a => a
mempty
            Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> FilePath -> Html
keyword FilePath
"include "
            Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
sig'
      decl_doc = Html -> Html
H.dd (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"desc_doc" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
doc'
  pure $ decl_header <> decl_doc

-- | @renderFiles important_imports imports@ produces HTML files
-- documenting the type-checked program @imports@, with the files in
-- @important_imports@ considered most important. The HTML files must
-- be written to the specific locations indicated in the return value,
-- or the relative links will be wrong.
renderFiles :: [ImportName] -> Imports -> ([(FilePath, Html)], Warnings)
renderFiles :: [ImportName] -> Imports -> ([(FilePath, Html)], Warnings)
renderFiles [ImportName]
important_imports Imports
imports = Writer Warnings [(FilePath, Html)]
-> ([(FilePath, Html)], Warnings)
forall w a. Writer w a -> (a, w)
runWriter (Writer Warnings [(FilePath, Html)]
 -> ([(FilePath, Html)], Warnings))
-> Writer Warnings [(FilePath, Html)]
-> ([(FilePath, Html)], Warnings)
forall a b. (a -> b) -> a -> b
$ do
  (import_pages, documented) <- WriterT Documented (Writer Warnings) [(ImportName, (Html, Html))]
-> WriterT
     Warnings Identity ([(ImportName, (Html, Html))], Documented)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT Documented (Writer Warnings) [(ImportName, (Html, Html))]
 -> WriterT
      Warnings Identity ([(ImportName, (Html, Html))], Documented))
-> WriterT
     Documented (Writer Warnings) [(ImportName, (Html, Html))]
-> WriterT
     Warnings Identity ([(ImportName, (Html, Html))], Documented)
forall a b. (a -> b) -> a -> b
$ Imports
-> ((ImportName, FileModule)
    -> WriterT Documented (Writer Warnings) (ImportName, (Html, Html)))
-> WriterT
     Documented (Writer Warnings) [(ImportName, (Html, Html))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Imports
imports (((ImportName, FileModule)
  -> WriterT Documented (Writer Warnings) (ImportName, (Html, Html)))
 -> WriterT
      Documented (Writer Warnings) [(ImportName, (Html, Html))])
-> ((ImportName, FileModule)
    -> WriterT Documented (Writer Warnings) (ImportName, (Html, Html)))
-> WriterT
     Documented (Writer Warnings) [(ImportName, (Html, Html))]
forall a b. (a -> b) -> a -> b
$ \(ImportName
current, FileModule
fm) -> do
    let ctx :: Context
ctx =
          Context
            { ctxCurrent :: FilePath
ctxCurrent = FilePath -> FilePath -> FilePath
makeRelative FilePath
"/" (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ ImportName -> FilePath
includeToFilePath ImportName
current,
              ctxFileMod :: FileModule
ctxFileMod = FileModule
fm,
              ctxImports :: Imports
ctxImports = Imports
imports,
              ctxNoLink :: NoLink
ctxNoLink = NoLink
forall a. Monoid a => a
mempty,
              ctxFileMap :: FileMap
ctxFileMap = FileMap
file_map,
              ctxVisibleMTys :: NoLink
ctxVisibleMTys = Prog -> NoLink
progModuleTypes (Prog -> NoLink) -> Prog -> NoLink
forall a b. (a -> b) -> a -> b
$ FileModule -> Prog
fileProg FileModule
fm
            }
    (ReaderT
   Context
   (WriterT Documented (Writer Warnings))
   (ImportName, (Html, Html))
 -> Context
 -> WriterT Documented (Writer Warnings) (ImportName, (Html, Html)))
-> Context
-> ReaderT
     Context
     (WriterT Documented (Writer Warnings))
     (ImportName, (Html, Html))
-> WriterT Documented (Writer Warnings) (ImportName, (Html, Html))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  Context
  (WriterT Documented (Writer Warnings))
  (ImportName, (Html, Html))
-> Context
-> WriterT Documented (Writer Warnings) (ImportName, (Html, Html))
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Context
ctx (ReaderT
   Context
   (WriterT Documented (Writer Warnings))
   (ImportName, (Html, Html))
 -> WriterT Documented (Writer Warnings) (ImportName, (Html, Html)))
-> ReaderT
     Context
     (WriterT Documented (Writer Warnings))
     (ImportName, (Html, Html))
-> WriterT Documented (Writer Warnings) (ImportName, (Html, Html))
forall a b. (a -> b) -> a -> b
$ do
      (first_paragraph, maybe_abstract, maybe_sections) <- Prog -> DocM (Html, Html, Html)
headerDoc (Prog -> DocM (Html, Html, Html))
-> Prog -> DocM (Html, Html, Html)
forall a b. (a -> b) -> a -> b
$ FileModule -> Prog
fileProg FileModule
fm

      synopsis <- (H.div ! A.id "module") <$> synopsisDecs (progDecs $ fileProg fm)

      description <- describeDecs $ progDecs $ fileProg fm

      pure
        ( current,
          ( H.docTypeHtml ! A.lang "en"
              $ addBoilerplateWithNav
                important_imports
                imports
                ("doc" </> includeToFilePath current)
                (includeToString current)
              $ H.main
              $ maybe_abstract
                <> selfLink "synopsis" (H.h2 "Synopsis")
                <> (H.div ! A.id "overview") synopsis
                <> selfLink "description" (H.h2 "Description")
                <> description
                <> maybe_sections,
            first_paragraph
          )
        )

  pure $
    [ ("index.html", contentsPage important_imports $ map (fmap snd) import_pages),
      ("doc-index.html", indexPage important_imports imports documented file_map)
    ]
      ++ map (importHtml *** fst) import_pages
  where
    file_map :: FileMap
file_map = Imports -> FileMap
vnameToFileMap Imports
imports
    importHtml :: ImportName -> FilePath
importHtml ImportName
import_name =
      FilePath
"doc" FilePath -> FilePath -> FilePath
</> FilePath -> FilePath -> FilePath
makeRelative FilePath
"/" (FilePath -> FilePath
forall a. IsString a => FilePath -> a
fromString (ImportName -> FilePath
includeToString ImportName
import_name)) FilePath -> FilePath -> FilePath
-<.> FilePath
"html"