{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Dhall.Docs.Html
( dhallFileToHtml
, textFileToHtml
, indexToHtml
, DocParams(..)
) where
import Data.Foldable (fold)
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
{ DocParams -> String
relativeResourcesPath :: FilePath
, DocParams -> Text
packageName :: Text
, DocParams -> CharacterSet
characterSet :: CharacterSet
, DocParams -> Maybe Text
baseImportUrl :: Maybe Text
}
dhallFileToHtml
:: Path Rel File
-> Text
-> Expr Src Import
-> [Expr Void Import]
-> Html ()
-> DocParams
-> Html ()
dhallFileToHtml :: Path Rel File
-> Text
-> Expr Src Import
-> [Expr Void Import]
-> Html ()
-> DocParams
-> Html ()
dhallFileToHtml Path Rel File
filePath Text
contents Expr Src Import
expr [Expr Void Import]
examples Html ()
header params :: DocParams
params@DocParams{String
Maybe Text
Text
CharacterSet
baseImportUrl :: Maybe Text
characterSet :: CharacterSet
packageName :: Text
relativeResourcesPath :: String
baseImportUrl :: DocParams -> Maybe Text
characterSet :: DocParams -> CharacterSet
packageName :: DocParams -> Text
relativeResourcesPath :: DocParams -> String
..} =
forall (m :: * -> *) a. Applicative m => HtmlT m a -> HtmlT m a
doctypehtml_ forall a b. (a -> b) -> a -> b
$ do
Text -> DocParams -> Html ()
headContents Text
htmlTitle DocParams
params
forall arg result. Term arg result => arg -> result
body_ forall a b. (a -> b) -> a -> b
$ do
DocParams -> Html ()
navBar DocParams
params
Html () -> Html ()
mainContainer forall a b. (a -> b) -> a -> b
$ do
DocParams -> HtmlFileType -> Breadcrumb -> Html ()
setPageTitle DocParams
params HtmlFileType
NotIndex Breadcrumb
breadcrumb
Text -> Html ()
copyToClipboardButton Text
clipboardText
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
br_ []
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ Text
"doc-contents"] Html ()
header
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr Void Import]
examples) forall a b. (a -> b) -> a -> b
$ do
forall arg result. Term arg result => arg -> result
h3_ Html ()
"Examples"
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ Text
"source-code code-examples"] forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (CharacterSet -> ExprType -> Expr Void Import -> Html ()
renderCodeSnippet CharacterSet
characterSet ExprType
AssertionExample) [Expr Void Import]
examples
forall arg result. Term arg result => arg -> result
h3_ Html ()
"Source"
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ Text
"source-code"] forall a b. (a -> b) -> a -> b
$ Text -> Expr Src Import -> Html ()
renderCodeWithHyperLinks Text
contents Expr Src Import
expr
where
breadcrumb :: Breadcrumb
breadcrumb = forall a. Path Rel a -> Breadcrumb
relPathToBreadcrumb Path Rel File
filePath
htmlTitle :: Text
htmlTitle = Breadcrumb -> Text
breadCrumbsToText Breadcrumb
breadcrumb
clipboardText :: Text
clipboardText = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Maybe Text
baseImportUrl forall a. Semigroup a => a -> a -> a
<> Text
htmlTitle
textFileToHtml
:: Path Rel File
-> Text
-> DocParams
-> Html ()
textFileToHtml :: Path Rel File -> Text -> DocParams -> Html ()
textFileToHtml Path Rel File
filePath Text
contents params :: DocParams
params@DocParams{String
Maybe Text
Text
CharacterSet
baseImportUrl :: Maybe Text
characterSet :: CharacterSet
packageName :: Text
relativeResourcesPath :: String
baseImportUrl :: DocParams -> Maybe Text
characterSet :: DocParams -> CharacterSet
packageName :: DocParams -> Text
relativeResourcesPath :: DocParams -> String
..} =
forall (m :: * -> *) a. Applicative m => HtmlT m a -> HtmlT m a
doctypehtml_ forall a b. (a -> b) -> a -> b
$ do
Text -> DocParams -> Html ()
headContents Text
htmlTitle DocParams
params
forall arg result. Term arg result => arg -> result
body_ forall a b. (a -> b) -> a -> b
$ do
DocParams -> Html ()
navBar DocParams
params
Html () -> Html ()
mainContainer forall a b. (a -> b) -> a -> b
$ do
DocParams -> HtmlFileType -> Breadcrumb -> Html ()
setPageTitle DocParams
params HtmlFileType
NotIndex Breadcrumb
breadcrumb
Text -> Html ()
copyToClipboardButton Text
clipboardText
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
br_ []
forall arg result. Term arg result => arg -> result
h3_ Html ()
"Source"
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ Text
"source-code"] (forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
contents)
where
breadcrumb :: Breadcrumb
breadcrumb = forall a. Path Rel a -> Breadcrumb
relPathToBreadcrumb Path Rel File
filePath
htmlTitle :: Text
htmlTitle = Breadcrumb -> Text
breadCrumbsToText Breadcrumb
breadcrumb
clipboardText :: Text
clipboardText = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Maybe Text
baseImportUrl forall a. Semigroup a => a -> a -> a
<> Text
htmlTitle
indexToHtml
:: Path Rel Dir
-> [(Path Rel File, Maybe (Expr Void Import))]
-> [Path Rel Dir]
-> DocParams
-> Html ()
indexToHtml :: Path Rel Dir
-> [(Path Rel File, Maybe (Expr Void Import))]
-> [Path Rel Dir]
-> DocParams
-> Html ()
indexToHtml Path Rel Dir
indexDir [(Path Rel File, Maybe (Expr Void Import))]
files [Path Rel Dir]
dirs params :: DocParams
params@DocParams{String
Maybe Text
Text
CharacterSet
baseImportUrl :: Maybe Text
characterSet :: CharacterSet
packageName :: Text
relativeResourcesPath :: String
baseImportUrl :: DocParams -> Maybe Text
characterSet :: DocParams -> CharacterSet
packageName :: DocParams -> Text
relativeResourcesPath :: DocParams -> String
..} = forall (m :: * -> *) a. Applicative m => HtmlT m a -> HtmlT m a
doctypehtml_ forall a b. (a -> b) -> a -> b
$ do
Text -> DocParams -> Html ()
headContents Text
htmlTitle DocParams
params
forall arg result. Term arg result => arg -> result
body_ forall a b. (a -> b) -> a -> b
$ do
DocParams -> Html ()
navBar DocParams
params
Html () -> Html ()
mainContainer forall a b. (a -> b) -> a -> b
$ do
DocParams -> HtmlFileType -> Breadcrumb -> Html ()
setPageTitle DocParams
params HtmlFileType
Index Breadcrumb
breadcrumbs
Text -> Html ()
copyToClipboardButton Text
clipboardText
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
br_ []
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Path Rel File, Maybe (Expr Void Import))]
files) forall a b. (a -> b) -> a -> b
$ do
forall arg result. Term arg result => arg -> result
h3_ Html ()
"Exported files: "
forall arg result. Term arg result => arg -> result
ul_ forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Path Rel File, Maybe (Expr Void Import)) -> Html ()
listFile [(Path Rel File, Maybe (Expr Void Import))]
files
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Rel Dir]
dirs) forall a b. (a -> b) -> a -> b
$ do
forall arg result. Term arg result => arg -> result
h3_ Html ()
"Exported packages: "
forall arg result. Term arg result => arg -> result
ul_ forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Path Rel Dir -> Html ()
listDir [Path Rel Dir]
dirs
where
listFile :: (Path Rel File, Maybe (Expr Void Import)) -> Html ()
listFile :: (Path Rel File, Maybe (Expr Void Import)) -> Html ()
listFile (Path Rel File
file, Maybe (Expr Void Import)
maybeType) =
let fileRef :: Text
fileRef = String -> Text
toUnixPath forall a b. (a -> b) -> a -> b
$ Path Rel File -> String
Path.fromRelFile Path Rel File
file
itemText :: Text
itemText = String -> Text
toUnixPath forall a b. (a -> b) -> a -> b
$ Path Rel File -> String
tryToTakeExt Path Rel File
file
in forall arg result. Term arg result => arg -> result
li_ forall a b. (a -> b) -> a -> b
$ do
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ Text
fileRef] forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
itemText
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
Data.Foldable.forM_ Maybe (Expr Void Import)
maybeType forall a b. (a -> b) -> a -> b
$ \Expr Void Import
typeExpr -> do
forall arg result. Term arg result => arg -> result
span_ [Text -> Attribute
class_ Text
"of-type-token"] Html ()
":"
forall arg result. Term arg result => arg -> result
span_ [Text -> Attribute
class_ Text
"dhall-type source-code"] forall a b. (a -> b) -> a -> b
$ CharacterSet -> ExprType -> Expr Void Import -> Html ()
renderCodeSnippet CharacterSet
characterSet ExprType
TypeAnnotation Expr Void Import
typeExpr
listDir :: Path Rel Dir -> Html ()
listDir :: Path Rel Dir -> Html ()
listDir Path Rel Dir
dir =
let dirPath :: Text
dirPath = String -> Text
toUnixPath forall a b. (a -> b) -> a -> b
$ Path Rel Dir -> String
Path.fromRelDir Path Rel Dir
dir in
forall arg result. Term arg result => arg -> result
li_ forall a b. (a -> b) -> a -> b
$ forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ (Text
dirPath forall a. Semigroup a => a -> a -> a
<> Text
"index.html")] forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
dirPath
tryToTakeExt :: Path Rel File -> FilePath
tryToTakeExt :: Path Rel File -> String
tryToTakeExt Path Rel File
file = Path Rel File -> String
Path.fromRelFile forall a b. (a -> b) -> a -> b
$ case forall (m :: * -> *) b.
MonadThrow m =>
Path b File -> m (Path b File, String)
Path.splitExtension Path Rel File
file of
Maybe (Path Rel File, String)
Nothing -> Path Rel File
file
Just (Path Rel File
f, String
_) -> Path Rel File
f
breadcrumbs :: Breadcrumb
breadcrumbs = forall a. Path Rel a -> Breadcrumb
relPathToBreadcrumb Path Rel Dir
indexDir
htmlTitle :: Text
htmlTitle = Breadcrumb -> Text
breadCrumbsToText Breadcrumb
breadcrumbs
clipboardText :: Text
clipboardText = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Maybe Text
baseImportUrl forall a. Semigroup a => a -> a -> a
<> Text
htmlTitle
copyToClipboardButton :: Text -> Html ()
copyToClipboardButton :: Text -> Html ()
copyToClipboardButton Text
filePath =
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
class_ Text
"copy-to-clipboard", Text -> Text -> Attribute
data_ Text
"path" Text
filePath]
forall a b. (a -> b) -> a -> b
$ forall arg result. Term arg result => arg -> result
i_ forall a b. (a -> b) -> a -> b
$ forall arg result. Term arg result => arg -> result
small_ Html ()
"Copy path to clipboard"
setPageTitle :: DocParams -> HtmlFileType -> Breadcrumb -> Html ()
setPageTitle :: DocParams -> HtmlFileType -> Breadcrumb -> Html ()
setPageTitle DocParams{String
Maybe Text
Text
CharacterSet
baseImportUrl :: Maybe Text
characterSet :: CharacterSet
packageName :: Text
relativeResourcesPath :: String
baseImportUrl :: DocParams -> Maybe Text
characterSet :: DocParams -> CharacterSet
packageName :: DocParams -> Text
relativeResourcesPath :: DocParams -> String
..} HtmlFileType
htmlFileType Breadcrumb
breadcrumb =
forall arg result. Term arg result => arg -> result
h2_ [Text -> Attribute
class_ Text
"doc-title"] forall a b. (a -> b) -> a -> b
$ do
forall arg result. Term arg result => arg -> result
span_ [Text -> Attribute
class_ Text
"crumb-divider"] Html ()
"/"
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ forall a b. (a -> b) -> a -> b
$ String -> Text
Data.Text.pack forall a b. (a -> b) -> a -> b
$ String
relativeResourcesPath forall a. Semigroup a => a -> a -> a
<> String
"index.html"]
forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
packageName
HtmlFileType -> Breadcrumb -> Html ()
breadCrumbsToHtml HtmlFileType
htmlFileType Breadcrumb
breadcrumb
data Breadcrumb
= Crumb Breadcrumb String
| EmptyCrumb
deriving Int -> Breadcrumb -> ShowS
[Breadcrumb] -> ShowS
Breadcrumb -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Breadcrumb] -> ShowS
$cshowList :: [Breadcrumb] -> ShowS
show :: Breadcrumb -> String
$cshow :: Breadcrumb -> String
showsPrec :: Int -> Breadcrumb -> ShowS
$cshowsPrec :: Int -> Breadcrumb -> ShowS
Show
data HtmlFileType = NotIndex | Index
relPathToBreadcrumb :: Path Rel a -> Breadcrumb
relPathToBreadcrumb :: forall a. Path Rel a -> Breadcrumb
relPathToBreadcrumb Path Rel a
relPath = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Breadcrumb -> String -> Breadcrumb
Crumb Breadcrumb
EmptyCrumb [String]
splittedRelPath
where
filePath :: String
filePath = forall b t. Path b t -> String
Path.toFilePath Path Rel a
relPath
splittedRelPath :: [String]
splittedRelPath :: [String]
splittedRelPath = case ShowS
FilePath.dropTrailingPathSeparator String
filePath of
String
"." -> [String
""]
String
_ -> String -> [String]
FilePath.splitDirectories String
filePath
breadCrumbsToHtml :: HtmlFileType -> Breadcrumb -> Html ()
breadCrumbsToHtml :: HtmlFileType -> Breadcrumb -> Html ()
breadCrumbsToHtml HtmlFileType
htmlFileType = Int -> Breadcrumb -> Html ()
go Int
startLevel
where
startLevel :: Int
startLevel = case HtmlFileType
htmlFileType of
HtmlFileType
NotIndex -> -Int
1
HtmlFileType
Index -> Int
0
go :: Int -> Breadcrumb -> Html ()
go :: Int -> Breadcrumb -> Html ()
go Int
_ Breadcrumb
EmptyCrumb = forall (m :: * -> *) a. Monad m => a -> m a
return ()
go Int
level (Crumb Breadcrumb
bc String
name) = do
Int -> Breadcrumb -> Html ()
go (Int
level forall a. Num a => a -> a -> a
+ Int
1) Breadcrumb
bc
forall arg result. Term arg result => arg -> result
span_ [Text -> Attribute
class_ Text
"crumb-divider"] forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (Text
"/" :: Text)
[Attribute] -> Html () -> Html ()
elem_ [Text -> Attribute
class_ Text
"title-crumb", Text -> Attribute
href_ Text
hrefTarget] forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml String
name
where
hrefTarget :: Text
hrefTarget = Int -> Text -> Text
Data.Text.replicate Int
level Text
"../" forall a. Semigroup a => a -> a -> a
<> Text
"index.html"
elem_ :: [Attribute] -> Html () -> Html ()
elem_ = if Int
level forall a. Eq a => a -> a -> Bool
== Int
startLevel then forall arg result. Term arg result => arg -> result
span_ else forall arg result. Term arg result => arg -> result
a_
breadCrumbsToText :: Breadcrumb -> Text
breadCrumbsToText :: Breadcrumb -> Text
breadCrumbsToText Breadcrumb
EmptyCrumb = Text
""
breadCrumbsToText (Crumb Breadcrumb
bc String
c) = Breadcrumb -> Text
breadCrumbsToText Breadcrumb
bc forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> String -> Text
Data.Text.pack String
c
navBar
:: DocParams
-> Html ()
navBar :: DocParams -> Html ()
navBar DocParams{String
Maybe Text
Text
CharacterSet
baseImportUrl :: Maybe Text
characterSet :: CharacterSet
packageName :: Text
relativeResourcesPath :: String
baseImportUrl :: DocParams -> Maybe Text
characterSet :: DocParams -> CharacterSet
packageName :: DocParams -> Text
relativeResourcesPath :: DocParams -> String
..} = forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ Text
"nav-bar"] forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
img_ [ Text -> Attribute
class_ Text
"dhall-icon"
, Text -> Attribute
src_ forall a b. (a -> b) -> a -> b
$ String -> Text
Data.Text.pack forall a b. (a -> b) -> a -> b
$ String
relativeResourcesPath forall a. Semigroup a => a -> a -> a
<> String
"dhall-icon.svg"
]
forall arg result. Term arg result => arg -> result
p_ [Text -> Attribute
class_ Text
"package-title"] forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
packageName
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ Text
"nav-bar-content-divider"] Html ()
""
forall a. With a => a -> [Attribute] -> a
with Html () -> Html ()
makeOption [Text -> Attribute
id_ Text
"switch-light-dark-mode"] Html ()
"Switch Light/Dark Mode"
where
makeOption :: Html () -> Html ()
makeOption = forall a. With a => a -> [Attribute] -> a
with forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
class_ Text
"nav-option"]
headContents :: Text -> DocParams -> Html ()
headContents :: Text -> DocParams -> Html ()
headContents Text
title DocParams{String
Maybe Text
Text
CharacterSet
baseImportUrl :: Maybe Text
characterSet :: CharacterSet
packageName :: Text
relativeResourcesPath :: String
baseImportUrl :: DocParams -> Maybe Text
characterSet :: DocParams -> CharacterSet
packageName :: DocParams -> Text
relativeResourcesPath :: DocParams -> String
..} =
forall arg result. Term arg result => arg -> result
head_ forall a b. (a -> b) -> a -> b
$ do
forall arg result. Term arg result => arg -> result
title_ forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
title
String -> Html ()
stylesheet forall a b. (a -> b) -> a -> b
$ String
relativeResourcesPath forall a. Semigroup a => a -> a -> a
<> String
"index.css"
String -> Html ()
stylesheet String
"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"
String -> Html ()
script String
relativeResourcesPath
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
meta_ [Text -> Attribute
charset_ Text
"UTF-8"]
mainContainer :: Html() -> Html ()
mainContainer :: Html () -> Html ()
mainContainer = forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ Text
"main-container"]
stylesheet :: FilePath -> Html ()
stylesheet :: String -> Html ()
stylesheet String
path =
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
link_
[ Text -> Attribute
rel_ Text
"stylesheet"
, Text -> Attribute
type_ Text
"text/css"
, Text -> Attribute
href_ forall a b. (a -> b) -> a -> b
$ String -> Text
Data.Text.pack String
path]
script :: FilePath -> Html ()
script :: String -> Html ()
script String
relativeResourcesPath =
forall arg result. TermRaw arg result => arg -> result
script_
[ Text -> Attribute
type_ Text
"text/javascript"
, Text -> Attribute
src_ forall a b. (a -> b) -> a -> b
$ String -> Text
Data.Text.pack forall a b. (a -> b) -> a -> b
$ String
relativeResourcesPath forall a. Semigroup a => a -> a -> a
<> String
"index.js"]
(Text
"" :: Text)
toUnixPath :: String -> Text
toUnixPath :: String -> Text
toUnixPath = Text -> Text -> Text -> Text
Data.Text.replace Text
"\\" Text
"/" forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Data.Text.pack