{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Dhall.Docs.Html
( dhallFileToHtml
, indexToHtml
, DocParams(..)
) where
import Data.Text (Text)
import Data.Void (Void)
import Dhall.Core (Expr, Import)
import Dhall.Docs.CodeRenderer
import Dhall.Pretty (CharacterSet)
import Dhall.Src (Src)
import Lucid
import Path (Dir, File, Path, Rel)
import qualified Control.Monad
import qualified Data.Foldable
import qualified Data.Text
import qualified Path
import qualified System.FilePath as FilePath
data DocParams = DocParams
{ relativeResourcesPath :: FilePath
, packageName :: Text
, characterSet :: CharacterSet
}
dhallFileToHtml
:: Path Rel File
-> Text
-> Expr Src Import
-> [Expr Void Import]
-> Html ()
-> DocParams
-> Html ()
dhallFileToHtml filePath contents expr examples header params@DocParams{..} =
doctypehtml_ $ do
headContents htmlTitle params
body_ $ do
navBar params
mainContainer $ do
setPageTitle params NotIndex breadcrumb
copyToClipboardButton htmlTitle
br_ []
div_ [class_ "doc-contents"] header
Control.Monad.unless (null examples) $ do
h3_ "Examples"
div_ [class_ "source-code code-examples"] $
mapM_ (renderCodeSnippet characterSet AssertionExample) examples
h3_ "Source"
div_ [class_ "source-code"] $ renderCodeWithHyperLinks contents expr
where
breadcrumb = relPathToBreadcrumb filePath
htmlTitle = breadCrumbsToText breadcrumb
indexToHtml
:: Path Rel Dir
-> [(Path Rel File, Maybe (Expr Void Import))]
-> [Path Rel Dir]
-> DocParams
-> Html ()
indexToHtml indexDir files dirs params@DocParams{..} = doctypehtml_ $ do
headContents htmlTitle params
body_ $ do
navBar params
mainContainer $ do
setPageTitle params Index breadcrumbs
copyToClipboardButton htmlTitle
br_ []
Control.Monad.unless (null files) $ do
h3_ "Exported files: "
ul_ $ mconcat $ map listFile files
Control.Monad.unless (null dirs) $ do
h3_ "Exported packages: "
ul_ $ mconcat $ map listDir dirs
where
listFile :: (Path Rel File, Maybe (Expr Void Import)) -> Html ()
listFile (file, maybeType) =
let fileRef = Data.Text.pack $ Path.fromRelFile file
itemText = Data.Text.pack $ tryToTakeExt file
in li_ $ do
a_ [href_ fileRef] $ toHtml itemText
Data.Foldable.forM_ maybeType $ \typeExpr -> do
span_ [class_ "of-type-token"] ":"
span_ [class_ "dhall-type source-code"] $ renderCodeSnippet characterSet TypeAnnotation typeExpr
listDir :: Path Rel Dir -> Html ()
listDir dir =
let dirPath = Data.Text.pack $ Path.fromRelDir dir in
li_ $ a_ [href_ (dirPath <> "index.html")] $ toHtml dirPath
tryToTakeExt :: Path Rel File -> FilePath
tryToTakeExt file = Path.fromRelFile $ case Path.splitExtension file of
Nothing -> file
Just (f, _) -> f
breadcrumbs = relPathToBreadcrumb indexDir
htmlTitle = breadCrumbsToText breadcrumbs
copyToClipboardButton :: Text -> Html ()
copyToClipboardButton filePath =
a_ [class_ "copy-to-clipboard", data_ "path" filePath]
$ i_ $ small_ "Copy path to clipboard"
setPageTitle :: DocParams -> HtmlFileType -> Breadcrumb -> Html ()
setPageTitle DocParams{..} htmlFileType breadcrumb =
h2_ [class_ "doc-title"] $ do
span_ [class_ "crumb-divider"] "/"
a_ [href_ $ Data.Text.pack $ relativeResourcesPath <> "index.html"]
$ toHtml packageName
breadCrumbsToHtml htmlFileType breadcrumb
data Breadcrumb
= Crumb Breadcrumb String
| EmptyCrumb
deriving Show
data HtmlFileType = NotIndex | Index
relPathToBreadcrumb :: Path Rel a -> Breadcrumb
relPathToBreadcrumb relPath = foldl Crumb EmptyCrumb splittedRelPath
where
filePath = Path.toFilePath relPath
splittedRelPath :: [String]
splittedRelPath = case FilePath.dropTrailingPathSeparator filePath of
"." -> [""]
_ -> FilePath.splitDirectories filePath
breadCrumbsToHtml :: HtmlFileType -> Breadcrumb -> Html ()
breadCrumbsToHtml htmlFileType = go startLevel
where
startLevel = case htmlFileType of
NotIndex -> -1
Index -> 0
go :: Int -> Breadcrumb -> Html ()
go _ EmptyCrumb = return ()
go level (Crumb bc name) = do
go (level + 1) bc
span_ [class_ "crumb-divider"] $ toHtml ("/" :: Text)
elem_ [class_ "title-crumb", href_ hrefTarget] $ toHtml name
where
hrefTarget = Data.Text.replicate level "../" <> "index.html"
elem_ = if level == startLevel then span_ else a_
breadCrumbsToText :: Breadcrumb -> Text
breadCrumbsToText EmptyCrumb = ""
breadCrumbsToText (Crumb bc c) = breadCrumbsToText bc <> "/" <> Data.Text.pack c
navBar
:: DocParams
-> Html ()
navBar DocParams{..} = div_ [class_ "nav-bar"] $ do
img_ [ class_ "dhall-icon"
, src_ $ Data.Text.pack $ relativeResourcesPath <> "dhall-icon.svg"
]
p_ [class_ "package-title"] $ toHtml packageName
div_ [class_ "nav-bar-content-divider"] ""
with makeOption [id_ "switch-light-dark-mode"] "Switch Light/Dark Mode"
where
makeOption = with a_ [class_ "nav-option"]
headContents :: Text -> DocParams -> Html ()
headContents title DocParams{..} =
head_ $ do
title_ $ toHtml title
stylesheet $ relativeResourcesPath <> "index.css"
stylesheet "https://fonts.googleapis.com/css2?family=Fira+Code:wght@400;500;600;700&family=Lato:ital,wght@0,400;0,700;1,400&display=swap"
script relativeResourcesPath
meta_ [charset_ "UTF-8"]
mainContainer :: Html() -> Html ()
mainContainer = div_ [class_ "main-container"]
stylesheet :: FilePath -> Html ()
stylesheet path =
link_
[ rel_ "stylesheet"
, type_ "text/css"
, href_ $ Data.Text.pack path]
script :: FilePath -> Html ()
script relativeResourcesPath =
script_
[ type_ "text/javascript"
, src_ $ Data.Text.pack $ relativeResourcesPath <> "index.js"]
("" :: Text)