content: -- | 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.Ord
  import Data.Set qualified as S
  import Data.String (fromString)
  import Data.Text qualified as T
  import Data.Version
  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, splitPath, (-<.>), (</>))
  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 = toHtml . docText
  
  primTypeHtml :: PrimType -> Html
  primTypeHtml = docToHtml . pretty
  
  prettyU :: Uniqueness -> Html
  prettyU = docToHtml . pretty
  
  renderName :: Name -> Html
  renderName name = docToHtml (pretty name)
  
  joinBy :: Html -> [Html] -> Html
  joinBy _ [] = mempty
  joinBy _ [x] = x
  joinBy sep (x : xs) = x <> foldMap (sep <>) xs
  
  commas :: [Html] -> Html
  commas = joinBy ", "
  
  parens :: Html -> Html
  parens x = "(" <> x <> ")"
  
  braces :: Html -> Html
  braces x = "{" <> x <> "}"
  
  brackets :: Html -> Html
  brackets x = "[" <> x <> "]"
  
  pipes :: [Html] -> Html
  pipes = joinBy " | "
  
  -- | 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 = nameToString . baseName
  
  vnameToFileMap :: Imports -> FileMap
  vnameToFileMap = mconcat . map forFile
    where
      forFile (file, FileModule _ file_env _prog _) =
        forEnv "" file_env
        where
          file' = makeRelative "/" $ includeToFilePath file
          vname prefix ns v =
            M.singleton (qualLeaf v) (file', canon ns $ prefix <> baseString (qualLeaf v))
          vname' prefix ((ns, _), v) = vname prefix ns v
          canon Term s = "term:" <> s
          canon Type s = "type:" <> s
          canon Signature s = "modtype:" <> s
  
          forEnv prefix env =
            mconcat (map (forType prefix) $ M.toList $ envTypeTable env)
              <> mconcat (map (forMod prefix) $ M.toList $ envModTable env)
              <> mconcat (map (forMty prefix) $ M.toList $ envModTypeTable env)
              <> mconcat (map (vname' prefix) $ M.toList $ envNameMap env)
          forMod prefix (name, ModEnv env) =
            forEnv (prefix <> baseString name <> ".") env
          forMod _ (_, ModFun {}) = mempty
          forMty prefix (name, MTy abs mod) =
            forMod prefix (name, mod)
              <> mconcat (map (vname prefix Type) (M.keys abs))
          forType prefix = vname prefix Type . qualName . fst
  
  data Context = Context
    { ctxCurrent :: String,
      ctxFileMod :: FileModule,
      ctxImports :: Imports,
      ctxNoLink :: NoLink,
      ctxFileMap :: FileMap,
      -- | Local module types that show up in the interface. These
      -- should be documented, but clearly marked local.
      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 s = lift $ lift $ tell $ singleWarning loc s
  
  document :: VName -> IndexWhat -> DocM ()
  document v what = tell $ M.singleton v what
  
  noLink :: [VName] -> DocM a -> DocM a
  noLink names = local $ \ctx ->
    ctx {ctxNoLink = S.fromList names <> ctxNoLink ctx}
  
  selfLink :: AttributeValue -> Html -> Html
  selfLink s = H.a ! A.id s ! A.href ("#" <> s) ! A.class_ "self_link"
  
  fullRow :: Html -> Html
  fullRow = H.tr . (H.td ! A.colspan "3")
  
  emptyRow :: Html
  emptyRow = H.tr $ H.td mempty <> H.td mempty <> H.td mempty
  
  specRow :: Html -> Html -> Html -> Html
  specRow a b c =
    H.tr $
      (H.td ! A.class_ "spec_lhs") a
        <> (H.td ! A.class_ "spec_eql") b
        <> (H.td ! A.class_ "spec_rhs") c
  
  -- | The header documentation (which need not be present) can contain
  -- an abstract and further sections.
  headerDoc :: Prog -> DocM (Html, Html, Html)
  headerDoc prog =
    case progDoc prog of
      Just (DocComment doc loc) -> do
        let (abstract, more_sections) = splitHeaderDoc $ T.unpack doc
        first_paragraph <- docHtml $ Just $ DocComment (firstParagraph abstract) 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'
          )
      _ -> pure mempty
    where
      splitHeaderDoc s =
        fromMaybe (s, mempty) $
          find (("\n##" `isPrefixOf`) . snd) $
            zip (inits s) (tails s)
      firstParagraph = T.pack . unlines . takeWhile (not . paragraphSeparator) . lines
      paragraphSeparator = all isSpace
  
  contentsPage :: [ImportName] -> [(ImportName, Html)] -> Html
  contentsPage important_imports pages =
    H.docTypeHtml $
      addBoilerplate "index.html" "Futhark Library Documentation" $
        H.main $
          ( if null important_pages
              then mempty
              else H.h2 "Main libraries" <> fileList important_pages
          )
            <> ( if null unimportant_pages
                   then mempty
                   else H.h2 "Supporting libraries" <> fileList unimportant_pages
               )
    where
      (important_pages, unimportant_pages) =
        partition ((`elem` important_imports) . fst) pages
  
      fileList pages' =
        H.dl ! A.class_ "file_list" $
          mconcat $
            map linkTo $
              sortOn fst pages'
  
      linkTo (name, maybe_abstract) =
        H.div ! A.class_ "file_desc" $
          (H.dt ! A.class_ "desc_header") (importLink "index.html" name)
            <> (H.dd ! A.class_ "desc_doc") maybe_abstract
  
  importLink :: FilePath -> ImportName -> Html
  importLink current name =
    let file =
          relativise
            ("doc" </> makeRelative "/" (includeToFilePath name) -<.> "html")
            current
     in (H.a ! A.href (fromString file) $ fromString (includeToString name))
  
  indexPage :: [ImportName] -> Imports -> Documented -> FileMap -> Html
  indexPage important_imports imports documented fm =
    H.docTypeHtml $
      addBoilerplateWithNav important_imports imports "doc-index.html" "Index" $
        H.main $
          ( H.ul ! A.id "doc_index_list" $
              mconcat $
                map initialListEntry $
                  letter_group_links ++ [symbol_group_link]
          )
            <> ( H.table ! A.id "doc_index" $
                   H.thead (H.tr $ H.td "Who" <> H.td "What" <> H.td "Where")
                     <> mconcat (letter_groups ++ [symbol_group])
               )
    where
      (letter_names, sym_names) =
        partition (isLetterName . baseString . fst) $
          sortOn (map toUpper . baseString . fst) $
            mapMaybe isDocumented $
              M.toList fm
  
      isDocumented (k, (file, k_id)) = do
        what <- M.lookup k documented
        Just (k, (file, (what, k_id)))
  
      (letter_groups, letter_group_links) =
        unzip $ map tbodyForNames $ groupBy sameInitial letter_names
      (symbol_group, symbol_group_link) =
        tbodyForInitial "Symbols" sym_names
  
      isLetterName [] = False
      isLetterName (c : _) = isAlpha c
  
      sameInitial (x, _) (y, _) =
        case (baseString x, baseString y) of
          (x' : _, y' : _) -> toUpper x' == toUpper y'
          _ -> False
  
      tbodyForNames names@((s, _) : _) =
        tbodyForInitial (map toUpper $ take 1 $ baseString s) names
      tbodyForNames _ = mempty
  
      tbodyForInitial initial names =
        ( H.tbody $ mconcat $ initial' : map linkTo names,
          initial
        )
        where
          initial' =
            H.tr
              $ H.td ! A.colspan "2" ! A.class_ "doc_index_initial"
              $ H.a
                ! A.id (fromString initial)
                ! A.href (fromString $ '#' : initial)
              $ fromString initial
  
      initialListEntry initial =
        H.li $ H.a ! A.href (fromString $ '#' : initial) $ fromString initial
  
      linkTo (name, (file, (what, name_id))) =
        let file' = makeRelative "/" file
            name_link = vnameLink' name_id "" file'
            link =
              (H.a ! A.href (fromString (makeRelative "/" $ "doc" </> name_link))) $
                fromString $
                  baseString name
            what' = case what of
              IndexValue -> "value"
              IndexFunction -> "function"
              IndexType -> "type"
              IndexModuleType -> "module type"
              IndexModule -> "module"
            html_file = "doc" </> file' -<.> "html"
         in H.tr $
              (H.td ! A.class_ "doc_index_name" $ link)
                <> (H.td ! A.class_ "doc_index_namespace" $ what')
                <> ( H.td ! A.class_ "doc_index_file" $
                       (H.a ! A.href (fromString html_file) $ fromString file)
                   )
  
  addBoilerplate :: String -> String -> Html -> Html
  addBoilerplate current titleText content =
    let headHtml =
          H.head $
            H.meta
              ! A.charset "utf-8"
              <> H.title (fromString titleText)
              <> H.link
                ! A.href (fromString $ relativise "style.css" current)
                ! A.rel "stylesheet"
                ! A.type_ "text/css"
  
        navigation =
          H.ul ! A.id "navigation" $
            H.li (H.a ! A.href (fromString $ relativise "index.html" current) $ "Contents")
              <> H.li (H.a ! A.href (fromString $ relativise "doc-index.html" current) $ "Index")
  
        madeByHtml =
          "Generated by "
            <> (H.a ! A.href futhark_doc_url) "futhark-doc"
            <> " "
            <> fromString (showVersion version)
     in headHtml
          <> H.body
            ( (H.div ! A.id "header") (H.h1 (toHtml titleText) <> navigation)
                <> (H.div ! A.id "content") content
                <> (H.div ! A.id "footer") madeByHtml
            )
    where
      futhark_doc_url =
        "https://futhark.readthedocs.io/en/latest/man/futhark-doc.html"
  
  addBoilerplateWithNav :: [ImportName] -> Imports -> String -> String -> Html -> Html
  addBoilerplateWithNav important_imports imports current titleText content =
    addBoilerplate current titleText $
      (H.nav ! A.id "filenav" $ files) <> content
    where
      files = H.ul $ mconcat $ map pp $ sort $ filter visible important_imports
      pp name = H.li $ importLink current name
      visible = (`elem` map fst imports)
  
  synopsisDecs :: [Dec] -> DocM Html
  synopsisDecs decs = do
    visible <- asks 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 visible fm dec = case dec of
    ModTypeDec s -> synopsisModType mempty s
    ModDec m -> synopsisMod fm m
    ValDec v -> synopsisValBind v
    TypeDec t -> synopsisType t
    OpenDec x _
      | Just opened <- synopsisOpened x -> Just $ do
          opened' <- opened
          pure $ fullRow $ keyword "open " <> opened'
      | otherwise ->
          Just $
            pure $
              fullRow $
                keyword "open" <> fromString (" <" <> prettyString x <> ">")
    LocalDec (ModTypeDec s) _
      | modTypeName s `S.member` visible ->
          synopsisModType (keyword "local" <> " ") s
    LocalDec {} -> Nothing
    ImportDec {} -> Nothing
  
  synopsisOpened :: ModExp -> Maybe (DocM Html)
  synopsisOpened (ModVar qn _) = Just $ qualNameHtml qn
  synopsisOpened (ModParens me _) = do
    me' <- synopsisOpened me
    Just $ parens <$> me'
  synopsisOpened (ModImport _ (Info file) _) = Just $ do
    current <- asks ctxCurrent
    let dest = fromString $ relativise (includeToFilePath file) current -<.> "html"
    pure $
      keyword "import "
        <> (H.a ! A.href dest) (fromString (show (includeToString file)))
  synopsisOpened (ModAscript _ se _ _) = Just $ do
    se' <- synopsisModTypeExp se
    pure $ "... : " <> se'
  synopsisOpened _ = Nothing
  
  vnameSynopsisDef :: VName -> DocM Html
  vnameSynopsisDef vname = do
    (_, vname_id) <- vnameId 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 vb = Just $ do
    name' <- vnameSynopsisDef $ valBindName vb
    (lhs, mhs, rhs) <- valBindHtml name' vb
    pure $ specRow lhs (mhs <> " : ") rhs
  
  valBindHtml :: Html -> ValBind -> DocM (Html, Html, Html)
  valBindHtml name (ValBind _ _ retdecl (Info rettype) tparams params _ _ _ _) = do
    tparams' <- mconcat <$> mapM (fmap (" " <>) . typeParamHtml) tparams
    let noLink' = noLink $ map typeParamName tparams <> foldMap patNames 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 prefix sb = Just $ do
    name' <- vnameSynopsisDef $ modTypeName sb
    fullRow <$> do
      se' <- synopsisModTypeExp $ modTypeExp sb
      pure $ prefix <> keyword "module type " <> name' <> " = " <> se'
  
  synopsisMod :: FileModule -> ModBind -> Maybe (DocM Html)
  synopsisMod fm (ModBind name ps sig _ _ _) =
    case sig of
      Nothing -> (proceed <=< envModType) <$> M.lookup name modtable
      Just (s, _) -> Just $ proceed =<< synopsisModTypeExp s
    where
      proceed sig' = do
        name' <- vnameSynopsisDef name
        ps' <- modParamHtml ps
        pure $ specRow (keyword "module " <> name') ": " (ps' <> sig')
  
      FileModule _abs Env {envModTable = modtable} _ _ = fm
      envModType (ModEnv e) = renderEnv e
      envModType (ModFun (FunModType _ _ (MTy _ m))) = envModType m
  
  synopsisType :: TypeBind -> Maybe (DocM Html)
  synopsisType tb = Just $ do
    name' <- vnameSynopsisDef $ typeAlias tb
    fullRow <$> typeBindHtml name' tb
  
  typeBindHtml :: Html -> TypeBind -> DocM Html
  typeBindHtml name' (TypeBind _ l tparams t _ _ _) = do
    t' <- noLink (map typeParamName tparams) $ typeExpHtml t
    abbrev <- typeAbbrevHtml l name' tparams
    pure $ abbrev <> " = " <> t'
  
  renderEnv :: Env -> DocM Html
  renderEnv (Env vtable ttable sigtable modtable _) = do
    typeBinds <- mapM renderTypeBind (M.toList 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 (name, _sig) =
    (keyword "module type " <>) <$> qualNameHtml (qualName name)
  
  renderMod :: (VName, Mod) -> DocM Html
  renderMod (name, _mod) =
    (keyword "module " <>) <$> qualNameHtml (qualName name)
  
  renderValBind :: (VName, BoundV) -> DocM Html
  renderValBind = fmap H.div . synopsisValBindBind
  
  renderTypeBind :: (VName, TypeBinding) -> DocM Html
  renderTypeBind (name, TypeAbbr l tps tp) = do
    tp' <- retTypeHtml $ toResRet Nonunique tp
    name' <- vnameHtml name
    abbrev <- typeAbbrevHtml l name' tps
    pure $ H.div $ abbrev <> " = " <> tp'
  
  synopsisValBindBind :: (VName, BoundV) -> DocM Html
  synopsisValBindBind (name, BoundV tps t) = do
    tps' <- mapM typeParamHtml tps
    t' <- typeHtml $ second (const Nonunique) t
    name' <- vnameHtml name
    pure $ keyword "val " <> name' <> mconcat (map (" " <>) tps') <> ": " <> t'
  
  dietHtml :: Diet -> Html
  dietHtml Consume = "*"
  dietHtml Observe = ""
  
  typeHtml :: TypeBase Size Uniqueness -> DocM Html
  typeHtml t = case t of
    Array u shape et -> do
      shape' <- prettyShape shape
      et' <- typeHtml $ Scalar $ second (const Nonunique) et
      pure $ prettyU u <> shape' <> et'
    Scalar (Prim et) -> pure $ primTypeHtml et
    Scalar (Record fs)
      | Just ts <- areTupleFields fs ->
          parens . commas <$> mapM typeHtml ts
      | otherwise ->
          braces . commas <$> mapM ppField (M.toList fs)
      where
        ppField (name, tp) = do
          tp' <- typeHtml tp
          pure $ toHtml (nameToString name) <> ": " <> tp'
    Scalar (TypeVar u et targs) -> do
      targs' <- mapM typeArgHtml targs
      et' <- qualNameHtml et
      pure $ prettyU u <> et' <> mconcat (map (" " <>) targs')
    Scalar (Arrow _ pname d t1 t2) -> do
      t1' <- typeHtml $ second (const Nonunique) t1
      t2' <- retTypeHtml t2
      case pname of
        Named v -> do
          v' <- vnameHtml v
          pure $ parens (v' <> ": " <> dietHtml d <> t1') <> " -> " <> t2'
        Unnamed ->
          pure $ dietHtml d <> t1' <> " -> " <> t2'
    Scalar (Sum cs) -> pipes <$> mapM ppClause (sortConstrs cs)
      where
        ppClause (n, ts) = joinBy " " . (ppConstr n :) <$> mapM typeHtml ts
        ppConstr name = "#" <> toHtml (nameToString name)
  
  retTypeHtml :: ResRetType -> DocM Html
  retTypeHtml (RetType [] t) = typeHtml t
  retTypeHtml (RetType dims t) = do
    t' <- typeHtml t
    dims' <- mapM vnameHtml dims
    pure $ "?" <> mconcat (map brackets dims') <> "." <> t'
  
  prettyShape :: Shape Size -> DocM Html
  prettyShape (Shape ds) =
    mconcat <$> mapM dimDeclHtml ds
  
  typeArgHtml :: TypeArg Size -> DocM Html
  typeArgHtml (TypeArgDim d) = dimDeclHtml d
  typeArgHtml (TypeArgType t) = typeHtml $ second (const Nonunique) t
  
  modParamHtml :: [ModParamBase Info VName] -> DocM Html
  modParamHtml [] = pure mempty
  modParamHtml (ModParam pname psig _ _ : mps) = do
    pname' <- vnameHtml pname
    psig' <- synopsisModTypeExp psig
    mps' <- modParamHtml mps
    pure $ "(" <> pname' <> ": " <> psig' <> ") -> " <> mps'
  
  synopsisModTypeExp :: ModTypeExpBase Info VName -> DocM Html
  synopsisModTypeExp e = case e of
    ModTypeVar v _ _ -> qualNameHtml v
    ModTypeParens e' _ -> parens <$> synopsisModTypeExp e'
    ModTypeSpecs ss _ -> braces . (H.table ! A.class_ "specs") . mconcat <$> mapM synopsisSpec ss
    ModTypeWith s (TypeRef v ps t _) _ -> do
      s' <- synopsisModTypeExp s
      t' <- typeExpHtml t
      v' <- qualNameHtml v
      ps' <- mconcat <$> mapM (fmap (" " <>) . typeParamHtml) ps
      pure $ s' <> keyword " with " <> v' <> ps' <> " = " <> t'
    ModTypeArrow Nothing e1 e2 _ ->
      liftM2 f (synopsisModTypeExp e1) (synopsisModTypeExp e2)
      where
        f e1' e2' = e1' <> " -> " <> e2'
    ModTypeArrow (Just v) e1 e2 _ ->
      do
        name <- vnameHtml v
        e1' <- synopsisModTypeExp e1
        e2' <- noLink [v] $ synopsisModTypeExp e2
        pure $ "(" <> name <> ": " <> e1' <> ") -> " <> e2'
  
  keyword :: String -> Html
  keyword = (H.span ! A.class_ "keyword") . fromString
  
  vnameHtml :: VName -> DocM Html
  vnameHtml vname = do
    (_, vname_id) <- vnameId 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 = do
    current <- asks ctxCurrent
    asks $ fromMaybe (current, show (baseTag vname)) . M.lookup vname . ctxFileMap
  
  vnameDescDef :: VName -> IndexWhat -> DocM Html
  vnameDescDef v what = do
    document v what
    (_, v_id) <- vnameId v
    pure $ H.a ! A.id (fromString v_id) $ renderName (baseName v)
  
  vnameSynopsisRef :: VName -> DocM Html
  vnameSynopsisRef v = do
    (_, v_id) <- vnameId v
    pure
      $ H.a
        ! A.class_ "synopsis_link"
        ! A.href (fromString ("#" <> "synopsis:" <> v_id))
      $ "↑"
  
  synopsisSpec :: SpecBase Info VName -> DocM Html
  synopsisSpec spec = case spec of
    TypeAbbrSpec tpsig -> do
      def <- vnameSynopsisDef $ typeAlias tpsig
      fullRow <$> typeBindHtml def tpsig
    TypeSpec l name ps _ _ -> do
      name' <- vnameSynopsisDef name
      ps' <- mconcat <$> mapM (fmap (" " <>) . typeParamHtml) ps
      pure $ fullRow $ keyword l' <> name' <> ps'
      where
        l' = case l of
          Unlifted -> "type "
          SizeLifted -> "type~ "
          Lifted -> "type^ "
    ValSpec name tparams rettype _ _ _ -> do
      tparams' <- mapM typeParamHtml tparams
      rettype' <- noLink (map typeParamName tparams) $ typeExpHtml rettype
      name' <- vnameSynopsisDef name
      pure $
        specRow
          (keyword "val " <> name')
          (mconcat (map (" " <>) tparams') <> ": ")
          rettype'
    ModSpec name sig _ _ -> do
      name' <- vnameSynopsisDef name
      specRow (keyword "module " <> name') ": " <$> synopsisModTypeExp sig
    IncludeSpec e _ -> fullRow . (keyword "include " <>) <$> synopsisModTypeExp e
  
  typeExpHtml :: TypeExp Exp VName -> DocM Html
  typeExpHtml e = case e of
    TEUnique t _ -> ("*" <>) <$> typeExpHtml t
    TEArray d at _ -> do
      at' <- typeExpHtml at
      d' <- dimExpHtml d
      pure $ d' <> at'
    TETuple ts _ -> parens . commas <$> mapM typeExpHtml ts
    TERecord fs _ -> braces . commas <$> mapM ppField fs
      where
        ppField (L _ name, t) = do
          t' <- typeExpHtml t
          pure $ toHtml (nameToString name) <> ": " <> t'
    TEVar name _ -> qualNameHtml name
    TEParens te _ -> parens <$> typeExpHtml te
    TEApply t arg _ -> do
      t' <- typeExpHtml t
      arg' <- typeArgExpHtml arg
      pure $ t' <> " " <> arg'
    TEArrow pname t1 t2 _ -> do
      t1' <- case t1 of
        TEArrow {} -> parens <$> typeExpHtml t1
        _ -> typeExpHtml t1
      t2' <- typeExpHtml t2
      case pname of
        Just v -> do
          v' <- vnameHtml v
          pure $ parens (v' <> ": " <> t1') <> " -> " <> t2'
        Nothing ->
          pure $ t1' <> " -> " <> t2'
    TESum cs _ -> pipes <$> mapM ppClause cs
      where
        ppClause (n, ts) = joinBy " " . (ppConstr n :) <$> mapM typeExpHtml ts
        ppConstr name = "#" <> toHtml (nameToString name)
    TEDim dims t _ -> do
      t' <- typeExpHtml t
      pure $ "?" <> mconcat (map (brackets . renderName . baseName) dims) <> "." <> t'
  
  qualNameHtml :: QualName VName -> DocM Html
  qualNameHtml (QualName names vname@(VName name tag)) =
    if tag <= maxIntrinsicTag
      then pure $ renderName name
      else f <$> ref
    where
      prefix :: Html
      prefix = mapM_ ((<> ".") . renderName . baseName) names
      f (Just s) = H.a ! A.href (fromString s) $ prefix <> renderName name
      f Nothing = prefix <> renderName name
  
      ref = do
        boring <- asks $ S.member vname . ctxNoLink
        if boring
          then pure Nothing
          else Just <$> vnameLink vname
  
  -- | The link for a VName.
  vnameLink :: VName -> DocM String
  vnameLink vname = do
    current <- asks ctxCurrent
    (file, tag) <- vnameId vname
    pure $ vnameLink' tag current file
  
  vnameLink' :: String -> FilePath -> FilePath -> String
  vnameLink' tag current file =
    if file == current
      then "#" ++ tag
      else relativise file current -<.> ".html#" ++ tag
  
  paramHtml :: Pat ParamType -> DocM Html
  paramHtml pat = do
    let (pat_param, d, t) = patternParam pat
    t' <- typeHtml $ second (const Nonunique) t
    case pat_param of
      Named v -> do
        v' <- vnameHtml v
        pure $ parens $ v' <> ": " <> dietHtml d <> t'
      Unnamed -> pure t'
  
  relativise :: FilePath -> FilePath -> FilePath
  relativise dest src =
    concat (replicate (length (splitPath src) - 1) "../") ++ makeRelative "/" dest
  
  dimDeclHtml :: Size -> DocM Html
  dimDeclHtml = pure . brackets . toHtml . prettyString
  
  dimExpHtml :: SizeExp Exp -> DocM Html
  dimExpHtml (SizeExpAny _) = pure $ brackets mempty
  dimExpHtml (SizeExp e _) = pure $ brackets $ toHtml $ prettyString e
  
  typeArgExpHtml :: TypeArgExp Exp VName -> DocM Html
  typeArgExpHtml (TypeArgExpSize d) = dimExpHtml d
  typeArgExpHtml (TypeArgExpType d) = typeExpHtml d
  
  typeParamHtml :: TypeParam -> DocM Html
  typeParamHtml (TypeParamDim name _) = do
    name' <- vnameHtml name
    pure $ brackets name'
  typeParamHtml (TypeParamType l name _) = do
    name' <- vnameHtml name
    pure $ "'" <> fromString (prettyString l) <> name'
  
  typeAbbrevHtml :: Liftedness -> Html -> [TypeParam] -> DocM Html
  typeAbbrevHtml l name params = do
    params' <- mconcat <$> mapM (fmap (" " <>) . typeParamHtml) params
    pure $ what <> name <> params'
    where
      what = keyword $ "type" <> prettyString l <> " "
  
  docHtml :: Maybe DocComment -> DocM Html
  docHtml (Just (DocComment doc loc)) =
    H.preEscapedText
      . GFM.commonmarkToHtml [] [GFM.extAutolink]
      . T.pack
      <$> identifierLinks (locOf loc) (T.unpack doc)
  docHtml Nothing = pure mempty
  
  identifierLinks :: Loc -> String -> DocM String
  identifierLinks _ [] = pure []
  identifierLinks loc s
    | Just ((name, namespace, file), s') <- identifierReference s = do
        let proceed x = (x <>) <$> identifierLinks loc s'
            unknown = proceed $ "`" <> name <> "`"
        case knownNamespace namespace of
          Just namespace' -> do
            maybe_v <- lookupName (namespace', name, file)
            case maybe_v of
              Nothing -> do
                warn loc $
                  "Identifier '"
                    <> fromString name
                    <> "' not found in namespace '"
                    <> fromString namespace
                    <> "'"
                    <> fromString (maybe "" (" in file " <>) file)
                    <> "."
                unknown
              Just v' -> do
                link <- vnameLink v'
                proceed $ "[`" <> name <> "`](" <> link <> ")"
          _ -> do
            warn loc $ "Unknown namespace '" <> fromString namespace <> "'."
            unknown
    where
      knownNamespace "term" = Just Term
      knownNamespace "mtype" = Just Signature
      knownNamespace "type" = Just Type
      knownNamespace _ = Nothing
  identifierLinks loc (c : s') = (c :) <$> identifierLinks loc s'
  
  lookupName :: (Namespace, String, Maybe FilePath) -> DocM (Maybe VName)
  lookupName (namespace, name, file) = do
    current <- asks ctxCurrent
    let file' = mkImportFrom (mkInitialImport current) <$> file
    env <- lookupEnvForFile file'
    case M.lookup (namespace, nameFromString name) . envNameMap =<< env of
      Nothing -> pure Nothing
      Just qn -> pure $ Just $ qualLeaf qn
  
  lookupEnvForFile :: Maybe ImportName -> DocM (Maybe Env)
  lookupEnvForFile Nothing = asks $ Just . fileEnv . ctxFileMod
  lookupEnvForFile (Just file) = asks $ fmap fileEnv . lookup file . ctxImports
  
  describeGeneric ::
    VName ->
    IndexWhat ->
    Maybe DocComment ->
    (Html -> DocM Html) ->
    DocM Html
  describeGeneric name what doc f = do
    name' <- H.span ! A.class_ "decl_name" <$> vnameDescDef name what
    decl_type <- f name'
    doc' <- docHtml doc
    ref <- vnameSynopsisRef name
    let decl_doc = H.dd ! A.class_ "desc_doc" $ doc'
        decl_header = (H.dt ! A.class_ "desc_header") (ref <> decl_type)
    pure $ decl_header <> decl_doc
  
  describeGenericMod ::
    VName ->
    IndexWhat ->
    ModTypeExp ->
    Maybe DocComment ->
    (Html -> DocM Html) ->
    DocM Html
  describeGenericMod name what se doc f = do
    name' <- H.span ! A.class_ "decl_name" <$> vnameDescDef name what
  
    decl_type <- f name'
  
    doc' <- case se of
      ModTypeSpecs specs _ -> (<>) <$> docHtml doc <*> describeSpecs specs
      _ -> docHtml doc
  
    ref <- vnameSynopsisRef name
  
    let decl_doc = H.dd ! A.class_ "desc_doc" $ doc'
        decl_header = (H.dt ! A.class_ "desc_header") $ ref <> decl_type
    pure $ decl_header <> decl_doc
  
  describeDecs :: [Dec] -> DocM Html
  describeDecs decs = do
    visible <- asks 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 _ (ValDec vb) = Just $
    describeGeneric (valBindName vb) (valBindWhat vb) (valBindDoc vb) $ \name -> do
      (lhs, mhs, rhs) <- valBindHtml name vb
      pure $ lhs <> mhs <> ": " <> rhs
  describeDec _ (TypeDec vb) =
    Just $
      describeGeneric (typeAlias vb) IndexType (typeDoc vb) (`typeBindHtml` vb)
  describeDec _ (ModTypeDec (ModTypeBind name se doc _)) = Just $
    describeGenericMod name IndexModuleType se doc $ \name' ->
      pure $ keyword "module type " <> name'
  describeDec _ (ModDec mb) = Just $
    describeGeneric (modName mb) IndexModule (modDoc mb) $ \name' ->
      pure $ keyword "module " <> name'
  describeDec _ OpenDec {} = Nothing
  describeDec visible (LocalDec (ModTypeDec (ModTypeBind name se doc _)) _)
    | name `S.member` visible = Just $
        describeGenericMod name IndexModuleType se doc $ \name' ->
          pure $ keyword "local module type " <> name'
  describeDec _ LocalDec {} = Nothing
  describeDec _ ImportDec {} = Nothing
  
  valBindWhat :: ValBind -> IndexWhat
  valBindWhat vb
    | null (valBindParams vb),
      RetType _ t <- unInfo $ valBindRetType vb,
      orderZero t =
        IndexValue
    | otherwise =
        IndexFunction
  
  describeSpecs :: [Spec] -> DocM Html
  describeSpecs specs =
    H.dl . mconcat <$> mapM describeSpec specs
  
  describeSpec :: Spec -> DocM Html
  describeSpec (ValSpec name tparams t _ doc _) =
    describeGeneric name what doc $ \name' -> do
      tparams' <- mconcat <$> mapM (fmap (" " <>) . typeParamHtml) tparams
      t' <- noLink (map typeParamName tparams) $ typeExpHtml t
      pure $ keyword "val " <> name' <> tparams' <> ": " <> t'
    where
      what =
        case t of
          TEArrow {} -> IndexFunction
          _ -> IndexValue
  describeSpec (TypeAbbrSpec vb) =
    describeGeneric (typeAlias vb) IndexType (typeDoc vb) (`typeBindHtml` vb)
  describeSpec (TypeSpec l name tparams doc _) =
    describeGeneric name IndexType doc $ \name' -> typeAbbrevHtml l name' tparams
  describeSpec (ModSpec name se doc _) =
    describeGenericMod name IndexModule se doc $ \name' ->
      case se of
        ModTypeSpecs {} -> pure $ keyword "module " <> name'
        _ -> do
          se' <- synopsisModTypeExp se
          pure $ keyword "module " <> name' <> ": " <> se'
  describeSpec (IncludeSpec sig _) = do
    sig' <- synopsisModTypeExp sig
    doc' <- docHtml Nothing
    let decl_header =
          (H.dt ! A.class_ "desc_header") $
            (H.span ! A.class_ "synopsis_link") mempty
              <> keyword "include "
              <> sig'
        decl_doc = H.dd ! A.class_ "desc_doc" $ 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 important_imports imports = runWriter $ do
    (import_pages, documented) <- runWriterT $ forM imports $ \(current, fm) -> do
      let ctx =
            Context
              { ctxCurrent = makeRelative "/" $ includeToFilePath current,
                ctxFileMod = fm,
                ctxImports = imports,
                ctxNoLink = mempty,
                ctxFileMap = file_map,
                ctxVisibleMTys = progModuleTypes $ fileProg fm
              }
      flip runReaderT ctx $ do
        (first_paragraph, maybe_abstract, maybe_sections) <- headerDoc $ fileProg 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 = vnameToFileMap imports
      importHtml import_name =
        "doc" </> makeRelative "/" (fromString (includeToString import_name)) -<.> "html"
  