{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Dhall.Docs.Core
(
generateDocs
, generateDocsPure
, GeneratedDocs(..)
, module Dhall.Docs.Comment
) where
import Control.Applicative (Alternative (..))
import Control.Monad.Writer.Class (MonadWriter)
import Data.ByteString (ByteString)
import Data.Function (on)
import Data.Map.Strict (Map)
import Data.Text (Text)
import Data.Void (Void)
import Dhall.Core
( Binding (..)
, Expr (..)
, Import
, MultiLet (..)
, Var (..)
, denote
)
import Dhall.Docs.Comment
import Dhall.Docs.Embedded
import Dhall.Docs.Html
import Dhall.Docs.Markdown
import Dhall.Docs.Store
import Dhall.Parser
( Header (..)
, ParseError (..)
, exprAndHeaderFromText
)
import Dhall.Pretty (CharacterSet)
import Dhall.Src (Src)
import Path (Abs, Dir, File, Path, Rel, (</>))
import Text.Megaparsec (ParseErrorBundle (..))
import qualified Control.Applicative as Applicative
import qualified Control.Monad
import qualified Control.Monad.Writer.Class as Writer
import qualified Data.ByteString
import qualified Data.List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Merge.Strict as Map.Merge
import qualified Data.Map.Strict as Map
import qualified Data.Maybe
import qualified Data.Maybe as Maybe
import qualified Data.Text
import qualified Data.Text.Encoding
import qualified Data.Text.IO as Text.IO
import qualified Data.Text.Lazy as Text.Lazy
import qualified Dhall.Core
import qualified Lucid
import qualified Path
import qualified Path.IO
import qualified System.FilePath as FilePath
import qualified Text.Megaparsec
data GeneratedDocs a = GeneratedDocs [DocsGenWarning] a
deriving (Int -> GeneratedDocs a -> ShowS
forall a. Show a => Int -> GeneratedDocs a -> ShowS
forall a. Show a => [GeneratedDocs a] -> ShowS
forall a. Show a => GeneratedDocs a -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [GeneratedDocs a] -> ShowS
$cshowList :: forall a. Show a => [GeneratedDocs a] -> ShowS
show :: GeneratedDocs a -> FilePath
$cshow :: forall a. Show a => GeneratedDocs a -> FilePath
showsPrec :: Int -> GeneratedDocs a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> GeneratedDocs a -> ShowS
Show)
instance Functor GeneratedDocs where
fmap :: forall a b. (a -> b) -> GeneratedDocs a -> GeneratedDocs b
fmap a -> b
f (GeneratedDocs [DocsGenWarning]
w a
a) = forall a. [DocsGenWarning] -> a -> GeneratedDocs a
GeneratedDocs [DocsGenWarning]
w (a -> b
f a
a)
instance Applicative GeneratedDocs where
pure :: forall a. a -> GeneratedDocs a
pure = forall a. [DocsGenWarning] -> a -> GeneratedDocs a
GeneratedDocs []
GeneratedDocs [DocsGenWarning]
w a -> b
f <*> :: forall a b.
GeneratedDocs (a -> b) -> GeneratedDocs a -> GeneratedDocs b
<*> GeneratedDocs [DocsGenWarning]
w' a
a = forall a. [DocsGenWarning] -> a -> GeneratedDocs a
GeneratedDocs ([DocsGenWarning]
w forall a. Semigroup a => a -> a -> a
<> [DocsGenWarning]
w') (a -> b
f a
a)
instance Monad GeneratedDocs where
GeneratedDocs [DocsGenWarning]
w a
a >>= :: forall a b.
GeneratedDocs a -> (a -> GeneratedDocs b) -> GeneratedDocs b
>>= a -> GeneratedDocs b
f =
let GeneratedDocs [DocsGenWarning]
w' b
b = a -> GeneratedDocs b
f a
a
in forall a. [DocsGenWarning] -> a -> GeneratedDocs a
GeneratedDocs ([DocsGenWarning]
w forall a. Semigroup a => a -> a -> a
<> [DocsGenWarning]
w') b
b
instance MonadWriter [DocsGenWarning] GeneratedDocs where
tell :: [DocsGenWarning] -> GeneratedDocs ()
tell [DocsGenWarning]
w = forall a. [DocsGenWarning] -> a -> GeneratedDocs a
GeneratedDocs [DocsGenWarning]
w ()
listen :: forall a. GeneratedDocs a -> GeneratedDocs (a, [DocsGenWarning])
listen (GeneratedDocs [DocsGenWarning]
w a
a) = forall a. [DocsGenWarning] -> a -> GeneratedDocs a
GeneratedDocs [DocsGenWarning]
w (a
a, [DocsGenWarning]
w)
pass :: forall a.
GeneratedDocs (a, [DocsGenWarning] -> [DocsGenWarning])
-> GeneratedDocs a
pass (GeneratedDocs [DocsGenWarning]
w (a
a, [DocsGenWarning] -> [DocsGenWarning]
f)) = forall a. [DocsGenWarning] -> a -> GeneratedDocs a
GeneratedDocs ([DocsGenWarning] -> [DocsGenWarning]
f [DocsGenWarning]
w) a
a
data DocsGenWarning
= InvalidDhall (Text.Megaparsec.ParseErrorBundle Text Void)
| InvalidMarkdown MarkdownParseError
| (Path Rel File) CommentParseError
warn :: String
warn :: FilePath
warn = FilePath
"\n\ESC[1;33mWarning\ESC[0m: "
instance Show DocsGenWarning where
show :: DocsGenWarning -> FilePath
show (InvalidDhall ParseErrorBundle Text Void
err) =
FilePath
warn forall a. Semigroup a => a -> a -> a
<> FilePath
"Invalid Input\n\n" forall a. Semigroup a => a -> a -> a
<>
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> FilePath
Text.Megaparsec.errorBundlePretty ParseErrorBundle Text Void
err forall a. Semigroup a => a -> a -> a
<>
FilePath
"... documentation won't be generated for this file"
show (InvalidMarkdown MarkdownParseError{ParseErrorBundle Text MMarkErr
unwrap :: MarkdownParseError -> ParseErrorBundle Text MMarkErr
unwrap :: ParseErrorBundle Text MMarkErr
..}) =
FilePath
warn forall a. Semigroup a => a -> a -> a
<>FilePath
"Header comment is not markdown\n\n" forall a. Semigroup a => a -> a -> a
<>
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> FilePath
Text.Megaparsec.errorBundlePretty ParseErrorBundle Text MMarkErr
unwrap forall a. Semigroup a => a -> a -> a
<>
FilePath
"The original non-markdown text will be pasted in the documentation"
show (DhallDocsCommentError Path Rel File
path CommentParseError
err) =
FilePath
warn forall a. Semigroup a => a -> a -> a
<> Path Rel File -> FilePath
Path.fromRelFile Path Rel File
path forall a. Semigroup a => a -> a -> a
<> FilePath
specificError
where
specificError :: FilePath
specificError = case CommentParseError
err of
CommentParseError
MissingNewlineOnBlockComment -> FilePath
": After the `|` marker of a block comment " forall a. Semigroup a => a -> a -> a
<>
FilePath
"there must be a newline (either \\n or \\r\\n)"
CommentParseError
SeveralSubseqDhallDocsComments -> FilePath
": Two dhall-docs comments in the same " forall a. Semigroup a => a -> a -> a
<>
FilePath
"comment section are forbidden"
CommentParseError
BadSingleLineCommentsAlignment -> FilePath
": dhall-docs's single line comments " forall a. Semigroup a => a -> a -> a
<>
FilePath
"must be aligned"
CommentParseError
BadPrefixesOnSingleLineComments -> FilePath
": dhall-docs's single line comments " forall a. Semigroup a => a -> a -> a
<>
FilePath
"must have specific prefixes:" forall a. Semigroup a => a -> a -> a
<>
FilePath
"* For the first line: \"--| \"\n" forall a. Semigroup a => a -> a -> a
<>
FilePath
"* For the rest of the linse: \"-- \""
newtype =
{ :: Maybe DhallDocsText
} deriving (Int -> FileComments -> ShowS
[FileComments] -> ShowS
FileComments -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [FileComments] -> ShowS
$cshowList :: [FileComments] -> ShowS
show :: FileComments -> FilePath
$cshow :: FileComments -> FilePath
showsPrec :: Int -> FileComments -> ShowS
$cshowsPrec :: Int -> FileComments -> ShowS
Show)
data RenderedFile = RenderedFile
{ RenderedFile -> Path Rel File
path :: Path Rel File
, RenderedFile -> Text
contents :: Text
, RenderedFile -> FileType
fileType :: FileType
} deriving (Int -> RenderedFile -> ShowS
[RenderedFile] -> ShowS
RenderedFile -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [RenderedFile] -> ShowS
$cshowList :: [RenderedFile] -> ShowS
show :: RenderedFile -> FilePath
$cshow :: RenderedFile -> FilePath
showsPrec :: Int -> RenderedFile -> ShowS
$cshowsPrec :: Int -> RenderedFile -> ShowS
Show)
data FileType
= DhallFile
{ FileType -> Expr Src Import
expr :: Expr Src Import
, FileType -> Maybe (Expr Void Import)
mType :: Maybe (Expr Void Import)
, FileType -> [Expr Void Import]
examples :: [Expr Void Import]
, :: FileComments
}
| TextFile
deriving (Int -> FileType -> ShowS
[FileType] -> ShowS
FileType -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [FileType] -> ShowS
$cshowList :: [FileType] -> ShowS
show :: FileType -> FilePath
$cshow :: FileType -> FilePath
showsPrec :: Int -> FileType -> ShowS
$cshowsPrec :: Int -> FileType -> ShowS
Show)
getAllRenderedFiles :: [(Path Rel File, ByteString)] -> GeneratedDocs [RenderedFile]
getAllRenderedFiles :: [(Path Rel File, ByteString)] -> GeneratedDocs [RenderedFile]
getAllRenderedFiles =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
Maybe.catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Path Rel File, Text) -> GeneratedDocs (Maybe RenderedFile)
toRenderedFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Path Rel File, ByteString)
-> [(Path Rel File, Text)] -> [(Path Rel File, Text)]
validFiles []
where
hasDhallExtension :: Path Rel File -> Bool
hasDhallExtension :: Path Rel File -> Bool
hasDhallExtension Path Rel File
absFile = case forall (m :: * -> *) b.
MonadThrow m =>
Path b File -> m (Path b File, FilePath)
Path.splitExtension Path Rel File
absFile of
Maybe (Path Rel File, FilePath)
Nothing -> Bool
False
Just (Path Rel File
_, FilePath
ext) -> FilePath
ext forall a. Eq a => a -> a -> Bool
== FilePath
".dhall"
validFiles :: (Path Rel File, ByteString) -> [(Path Rel File, Text)] -> [(Path Rel File, Text)]
validFiles :: (Path Rel File, ByteString)
-> [(Path Rel File, Text)] -> [(Path Rel File, Text)]
validFiles (Path Rel File
relFile, ByteString
content) [(Path Rel File, Text)]
xs = case ByteString -> Either UnicodeException Text
Data.Text.Encoding.decodeUtf8' ByteString
content of
Left UnicodeException
_ -> [(Path Rel File, Text)]
xs
Right Text
textContent -> (Path Rel File
relFile, Text
textContent) forall a. a -> [a] -> [a]
: [(Path Rel File, Text)]
xs
toRenderedFile
:: (Path Rel File, Text) -> GeneratedDocs (Maybe RenderedFile)
toRenderedFile :: (Path Rel File, Text) -> GeneratedDocs (Maybe RenderedFile)
toRenderedFile (Path Rel File
relFile, Text
contents) =
case FilePath -> Text -> Either ParseError (Header, Expr Src Import)
exprAndHeaderFromText (Path Rel File -> FilePath
Path.fromRelFile Path Rel File
relFile) Text
contents of
Right (Header Text
header, Expr Src Import
expr) -> do
let denoted :: Expr Void Import
denoted = forall s a t. Expr s a -> Expr t a
denote Expr Src Import
expr :: Expr Void Import
Maybe DhallDocsText
headerContents <-
case FilePath
-> Text -> Maybe (Either [CommentParseError] DhallDocsText)
parseSingleDhallDocsComment (Path Rel File -> FilePath
Path.fromRelFile Path Rel File
relFile) Text
header of
Maybe (Either [CommentParseError] DhallDocsText)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just (Left [CommentParseError]
errs) -> do
forall w (m :: * -> *). MonadWriter w m => w -> m ()
Writer.tell forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Path Rel File -> CommentParseError -> DocsGenWarning
DhallDocsCommentError Path Rel File
relFile) [CommentParseError]
errs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just (Right DhallDocsText
c) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just DhallDocsText
c
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ RenderedFile
{ Text
contents :: Text
contents :: Text
contents
, path :: Path Rel File
path = Path Rel File
relFile
, fileType :: FileType
fileType = DhallFile
{ Expr Src Import
expr :: Expr Src Import
expr :: Expr Src Import
expr
, mType :: Maybe (Expr Void Import)
mType = Expr Void Import -> Maybe (Expr Void Import)
extractTypeIfInSource Expr Void Import
denoted
, examples :: [Expr Void Import]
examples = Expr Void Import -> [Expr Void Import]
examplesFromAssertions Expr Void Import
denoted
, fileComments :: FileComments
fileComments = Maybe DhallDocsText -> FileComments
FileComments Maybe DhallDocsText
headerContents
}
}
Left ParseError{Text
ParseErrorBundle Text Void
unwrap :: ParseError -> ParseErrorBundle Text Void
input :: ParseError -> Text
input :: Text
unwrap :: ParseErrorBundle Text Void
..} | Path Rel File -> Bool
hasDhallExtension Path Rel File
relFile -> do
forall w (m :: * -> *). MonadWriter w m => w -> m ()
Writer.tell [ParseErrorBundle Text Void -> DocsGenWarning
InvalidDhall ParseErrorBundle Text Void
unwrap]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Left ParseError
_ -> do
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ RenderedFile
{ Text
contents :: Text
contents :: Text
contents
, path :: Path Rel File
path = Path Rel File
relFile
, fileType :: FileType
fileType = FileType
TextFile
}
bindings :: Expr Void Import -> [Binding Void Import]
bindings :: Expr Void Import -> [Binding Void Import]
bindings Expr Void Import
expr = case Expr Void Import
expr of
Let b :: Binding Void Import
b@Binding{} Expr Void Import
e ->
let MultiLet NonEmpty (Binding Void Import)
bs Expr Void Import
_ = forall s a. Binding s a -> Expr s a -> MultiLet s a
Dhall.Core.multiLet Binding Void Import
b Expr Void Import
e
in forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (Binding Void Import)
bs
Expr Void Import
_ -> []
extractTypeIfInSource :: Expr Void Import -> Maybe (Expr Void Import)
extractTypeIfInSource :: Expr Void Import -> Maybe (Expr Void Import)
extractTypeIfInSource Expr Void Import
expr =
forall {f :: * -> *} {s} {a}.
Alternative f =>
Expr s a -> f (Expr s a)
fromOrdinaryAnnotation Expr Void Import
expr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Expr Void Import)
fromLetBindingAnnotation
where
fromOrdinaryAnnotation :: Expr s a -> f (Expr s a)
fromOrdinaryAnnotation (Let Binding s a
_ Expr s a
e) = Expr s a -> f (Expr s a)
fromOrdinaryAnnotation Expr s a
e
fromOrdinaryAnnotation (Annot Expr s a
_ Expr s a
_T) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr s a
_T
fromOrdinaryAnnotation Expr s a
_ = forall (f :: * -> *) a. Alternative f => f a
empty
fromLetBindingAnnotation :: Maybe (Expr Void Import)
fromLetBindingAnnotation = do
V Text
name Int
index <- Expr Void Import -> Maybe Var
maybeNameInLet Expr Void Import
expr
(Binding Maybe Void
_ Text
_ Maybe Void
_ (Just (Maybe Void
_, Expr Void Import
exprType)) Maybe Void
_ Expr Void Import
_) <-
Int -> [Binding Void Import] -> Maybe (Binding Void Import)
getLetBindingWithIndex Int
index forall a b. (a -> b) -> a -> b
$ Text -> [Binding Void Import]
getLetBindingsWithName Text
name
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Void Import
exprType
maybeNameInLet :: Expr Void Import -> Maybe Var
maybeNameInLet :: Expr Void Import -> Maybe Var
maybeNameInLet (Var v :: Var
v@(V Text
_ Int
_)) = forall a. a -> Maybe a
Just Var
v
maybeNameInLet (Let Binding Void Import
_ Expr Void Import
e) = Expr Void Import -> Maybe Var
maybeNameInLet Expr Void Import
e
maybeNameInLet Expr Void Import
_ = forall a. Maybe a
Nothing
getLetBindingsWithName :: Text -> [Binding Void Import]
getLetBindingsWithName :: Text -> [Binding Void Import]
getLetBindingsWithName Text
name = forall a. (a -> Bool) -> [a] -> [a]
filter forall {s} {a}. Binding s a -> Bool
bindName forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ Expr Void Import -> [Binding Void Import]
bindings Expr Void Import
expr
where
bindName :: Binding s a -> Bool
bindName (Binding Maybe s
_ Text
x Maybe s
_ Maybe (Maybe s, Expr s a)
_ Maybe s
_ Expr s a
_) = Text
x forall a. Eq a => a -> a -> Bool
== Text
name
getLetBindingWithIndex :: Int -> [Binding Void Import] -> Maybe (Binding Void Import)
getLetBindingWithIndex :: Int -> [Binding Void Import] -> Maybe (Binding Void Import)
getLetBindingWithIndex Int
i [Binding Void Import]
bs =
case forall a. Int -> [a] -> [a]
drop Int
i [Binding Void Import]
bs of
[] -> forall a. Maybe a
Nothing
Binding Void Import
binding : [Binding Void Import]
_ -> forall a. a -> Maybe a
Just Binding Void Import
binding
examplesFromAssertions :: Expr Void Import -> [Expr Void Import]
examplesFromAssertions :: Expr Void Import -> [Expr Void Import]
examplesFromAssertions Expr Void Import
expr = forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe Expr Void Import -> Maybe (Expr Void Import)
fromAssertion [Expr Void Import]
values
where
values :: [Expr Void Import]
values :: [Expr Void Import]
values = forall a b. (a -> b) -> [a] -> [b]
map forall s a. Binding s a -> Expr s a
value forall a b. (a -> b) -> a -> b
$ Expr Void Import -> [Binding Void Import]
bindings Expr Void Import
expr
fromAssertion :: Expr Void Import -> Maybe (Expr Void Import)
fromAssertion :: Expr Void Import -> Maybe (Expr Void Import)
fromAssertion (Assert Expr Void Import
e) = forall a. a -> Maybe a
Just Expr Void Import
e
fromAssertion Expr Void Import
_ = forall a. Maybe a
Nothing
resolveRelativePath :: Path Rel Dir -> FilePath
resolveRelativePath :: Path Rel Dir -> FilePath
resolveRelativePath Path Rel Dir
currentDir =
case ShowS
FilePath.dropTrailingPathSeparator forall a b. (a -> b) -> a -> b
$ Path Rel Dir -> FilePath
Path.fromRelDir Path Rel Dir
currentDir of
FilePath
"." -> FilePath
""
FilePath
_ -> FilePath
"../" forall a. Semigroup a => a -> a -> a
<> Path Rel Dir -> FilePath
resolveRelativePath (forall b t. Path b t -> Path b Dir
Path.parent Path Rel Dir
currentDir)
makeHtml
:: Maybe Text
-> Text
-> CharacterSet
-> RenderedFile
-> GeneratedDocs Text
makeHtml :: Maybe Text
-> Text -> CharacterSet -> RenderedFile -> GeneratedDocs Text
makeHtml Maybe Text
baseImportUrl Text
packageName CharacterSet
characterSet RenderedFile{Text
Path Rel File
FileType
fileType :: FileType
contents :: Text
path :: Path Rel File
fileType :: RenderedFile -> FileType
contents :: RenderedFile -> Text
path :: RenderedFile -> Path Rel File
..} = do
let relativeResourcesPath :: FilePath
relativeResourcesPath = Path Rel Dir -> FilePath
resolveRelativePath (forall b t. Path b t -> Path b Dir
Path.parent Path Rel File
path)
case FileType
fileType of
DhallFile{[Expr Void Import]
Maybe (Expr Void Import)
Expr Src Import
FileComments
fileComments :: FileComments
examples :: [Expr Void Import]
mType :: Maybe (Expr Void Import)
expr :: Expr Src Import
fileComments :: FileType -> FileComments
examples :: FileType -> [Expr Void Import]
mType :: FileType -> Maybe (Expr Void Import)
expr :: FileType -> Expr Src Import
..} -> do
let strippedHeader :: Text
strippedHeader =
forall b a. b -> (a -> b) -> Maybe a -> b
Maybe.maybe Text
"" DhallDocsText -> Text
unDhallDocsText (FileComments -> Maybe DhallDocsText
headerComment FileComments
fileComments)
HtmlT Identity ()
headerAsHtml <-
case Path Rel File
-> Text -> Either MarkdownParseError (HtmlT Identity ())
markdownToHtml Path Rel File
path Text
strippedHeader of
Left MarkdownParseError
err -> do
forall w (m :: * -> *). MonadWriter w m => w -> m ()
Writer.tell [MarkdownParseError -> DocsGenWarning
InvalidMarkdown MarkdownParseError
err]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
Lucid.toHtml Text
strippedHeader
Right HtmlT Identity ()
html -> forall (m :: * -> *) a. Monad m => a -> m a
return HtmlT Identity ()
html
let htmlAsText :: Text
htmlAsText =
Text -> Text
Text.Lazy.toStrict forall a b. (a -> b) -> a -> b
$ forall a. Html a -> Text
Lucid.renderText forall a b. (a -> b) -> a -> b
$ Path Rel File
-> Text
-> Expr Src Import
-> [Expr Void Import]
-> HtmlT Identity ()
-> DocParams
-> HtmlT Identity ()
dhallFileToHtml
Path Rel File
path
Text
contents
Expr Src Import
expr
[Expr Void Import]
examples
HtmlT Identity ()
headerAsHtml
DocParams{ FilePath
relativeResourcesPath :: FilePath
relativeResourcesPath :: FilePath
relativeResourcesPath, Text
packageName :: Text
packageName :: Text
packageName, CharacterSet
characterSet :: CharacterSet
characterSet :: CharacterSet
characterSet, Maybe Text
baseImportUrl :: Maybe Text
baseImportUrl :: Maybe Text
baseImportUrl }
forall (m :: * -> *) a. Monad m => a -> m a
return Text
htmlAsText
FileType
TextFile -> do
let htmlAsText :: Text
htmlAsText =
Text -> Text
Text.Lazy.toStrict forall a b. (a -> b) -> a -> b
$ forall a. Html a -> Text
Lucid.renderText forall a b. (a -> b) -> a -> b
$ Path Rel File -> Text -> DocParams -> HtmlT Identity ()
textFileToHtml
Path Rel File
path
Text
contents
DocParams{ FilePath
relativeResourcesPath :: FilePath
relativeResourcesPath :: FilePath
relativeResourcesPath, Text
packageName :: Text
packageName :: Text
packageName, CharacterSet
characterSet :: CharacterSet
characterSet :: CharacterSet
characterSet, Maybe Text
baseImportUrl :: Maybe Text
baseImportUrl :: Maybe Text
baseImportUrl }
forall (m :: * -> *) a. Monad m => a -> m a
return Text
htmlAsText
createIndexes
:: Maybe Text
-> Text
-> CharacterSet
-> [RenderedFile]
-> [(Path Rel File, Text)]
createIndexes :: Maybe Text
-> Text
-> CharacterSet
-> [RenderedFile]
-> [(Path Rel File, Text)]
createIndexes Maybe Text
baseImportUrl Text
packageName CharacterSet
characterSet [RenderedFile]
renderedFiles = forall a b. (a -> b) -> [a] -> [b]
map (Path Rel Dir, ([RenderedFile], [Path Rel Dir]))
-> (Path Rel File, Text)
toIndex [(Path Rel Dir, ([RenderedFile], [Path Rel Dir]))]
dirToDirsAndFilesMapAssocs
where
dirToFilesMap :: Map (Path Rel Dir) [RenderedFile]
dirToFilesMap :: Map (Path Rel Dir) [RenderedFile]
dirToFilesMap = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall a. Semigroup a => a -> a -> a
(<>) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map RenderedFile -> Map (Path Rel Dir) [RenderedFile]
toMap forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
Data.List.sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` RenderedFile -> Path Rel File
path) [RenderedFile]
renderedFiles
where
toMap :: RenderedFile -> Map (Path Rel Dir) [RenderedFile]
toMap :: RenderedFile -> Map (Path Rel Dir) [RenderedFile]
toMap RenderedFile
renderedFile = forall k a. k -> a -> Map k a
Map.singleton (forall b t. Path b t -> Path b Dir
Path.parent forall a b. (a -> b) -> a -> b
$ RenderedFile -> Path Rel File
path RenderedFile
renderedFile) [RenderedFile
renderedFile]
dirToDirsMap :: Map (Path Rel Dir) [Path Rel Dir]
dirToDirsMap :: Map (Path Rel Dir) [Path Rel Dir]
dirToDirsMap = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {b} {t}.
Path b t
-> Map (Path b Dir) [Path b t] -> Map (Path b Dir) [Path b t]
cons forall k a. Map k a
Map.empty [Path Rel Dir]
dirs
where
dirs :: [Path Rel Dir]
dirs = forall a. (a -> Bool) -> [a] -> [a]
filter forall {b}. Path b Dir -> Bool
keep (forall k a. Map k a -> [k]
Map.keys Map (Path Rel Dir) [RenderedFile]
dirToFilesMap)
where
keep :: Path b Dir -> Bool
keep Path b Dir
reldir = forall b t. Path b t -> Path b Dir
Path.parent Path b Dir
reldir forall a. Eq a => a -> a -> Bool
/= Path b Dir
reldir
cons :: Path b t
-> Map (Path b Dir) [Path b t] -> Map (Path b Dir) [Path b t]
cons Path b t
d = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. Semigroup a => a -> a -> a
(<>) (forall b t. Path b t -> Path b Dir
Path.parent Path b t
d) [Path b t
d]
dirToDirsAndFilesMapAssocs :: [(Path Rel Dir, ([RenderedFile], [Path Rel Dir]))]
dirToDirsAndFilesMapAssocs :: [(Path Rel Dir, ([RenderedFile], [Path Rel Dir]))]
dirToDirsAndFilesMapAssocs = forall k a. Map k a -> [(k, a)]
Map.assocs forall a b. (a -> b) -> a -> b
$
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Map.Merge.merge
(forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.Merge.mapMissing forall {p} {a} {a}. p -> a -> (a, [a])
onlyFiles)
(forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.Merge.mapMissing forall {p} {b} {a}. p -> b -> ([a], b)
onlyDirectories)
(forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
Map.Merge.zipWithMatched forall {p} {a} {b}. p -> a -> b -> (a, b)
both)
Map (Path Rel Dir) [RenderedFile]
dirToFilesMap
Map (Path Rel Dir) [Path Rel Dir]
dirToDirsMap
where
onlyFiles :: p -> a -> (a, [a])
onlyFiles p
_ a
files = (a
files, [] )
onlyDirectories :: p -> b -> ([a], b)
onlyDirectories p
_ b
directories = ([] , b
directories)
both :: p -> a -> b -> (a, b)
both p
_ a
files b
directories = (a
files, b
directories)
toIndex :: (Path Rel Dir, ([RenderedFile], [Path Rel Dir])) -> (Path Rel File, Text)
toIndex :: (Path Rel Dir, ([RenderedFile], [Path Rel Dir]))
-> (Path Rel File, Text)
toIndex (Path Rel Dir
indexDir, ([RenderedFile]
files, [Path Rel Dir]
dirs)) =
(Path Rel Dir
indexDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> $(Path.mkRelFile "index.html"), Text -> Text
Text.Lazy.toStrict forall a b. (a -> b) -> a -> b
$ forall a. Html a -> Text
Lucid.renderText HtmlT Identity ()
html)
where
adapt :: RenderedFile -> (Path Rel File, Maybe (Expr Void Import))
adapt RenderedFile{Text
Path Rel File
FileType
fileType :: FileType
contents :: Text
path :: Path Rel File
fileType :: RenderedFile -> FileType
contents :: RenderedFile -> Text
path :: RenderedFile -> Path Rel File
..} = (forall a. Path Rel a -> Path Rel a
stripPrefix (Path Rel File -> Path Rel File
addHtmlExt Path Rel File
path), Maybe (Expr Void Import)
m)
where
m :: Maybe (Expr Void Import)
m = case FileType
fileType of
DhallFile{[Expr Void Import]
Maybe (Expr Void Import)
Expr Src Import
FileComments
fileComments :: FileComments
examples :: [Expr Void Import]
mType :: Maybe (Expr Void Import)
expr :: Expr Src Import
fileComments :: FileType -> FileComments
examples :: FileType -> [Expr Void Import]
mType :: FileType -> Maybe (Expr Void Import)
expr :: FileType -> Expr Src Import
..} -> Maybe (Expr Void Import)
mType
FileType
TextFile -> forall a. Maybe a
Nothing
html :: HtmlT Identity ()
html = Path Rel Dir
-> [(Path Rel File, Maybe (Expr Void Import))]
-> [Path Rel Dir]
-> DocParams
-> HtmlT Identity ()
indexToHtml
Path Rel Dir
indexDir
(forall a b. (a -> b) -> [a] -> [b]
map RenderedFile -> (Path Rel File, Maybe (Expr Void Import))
adapt [RenderedFile]
files)
(forall a b. (a -> b) -> [a] -> [b]
map forall a. Path Rel a -> Path Rel a
stripPrefix [Path Rel Dir]
dirs)
DocParams { relativeResourcesPath :: FilePath
relativeResourcesPath = Path Rel Dir -> FilePath
resolveRelativePath Path Rel Dir
indexDir, Text
packageName :: Text
packageName :: Text
packageName, CharacterSet
characterSet :: CharacterSet
characterSet :: CharacterSet
characterSet, Maybe Text
baseImportUrl :: Maybe Text
baseImportUrl :: Maybe Text
baseImportUrl }
stripPrefix :: Path Rel a -> Path Rel a
stripPrefix :: forall a. Path Rel a -> Path Rel a
stripPrefix Path Rel a
relpath =
if forall b t. Path b t -> FilePath
Path.toFilePath Path Rel a
relpath forall a. Eq a => a -> a -> Bool
== forall b t. Path b t -> FilePath
Path.toFilePath Path Rel Dir
indexDir then Path Rel a
relpath
else forall a. a -> Maybe a -> a
Data.Maybe.fromMaybe (forall a. Text -> a
fileAnIssue Text
"Bug+with+stripPrefix")
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
Path.stripProperPrefix Path Rel Dir
indexDir Path Rel a
relpath
addHtmlExt :: Path Rel File -> Path Rel File
addHtmlExt :: Path Rel File -> Path Rel File
addHtmlExt Path Rel File
relFile =
forall a. a -> Maybe a -> a
Data.Maybe.fromMaybe (forall a. Text -> a
fileAnIssue Text
"addHtmlExt") forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b.
MonadThrow m =>
FilePath -> Path b File -> m (Path b File)
Path.addExtension FilePath
".html" Path Rel File
relFile
fileAnIssue :: Text -> a
fileAnIssue :: forall a. Text -> a
fileAnIssue Text
titleName =
forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"\ESC[1;31mError\ESC[0m Documentation generator bug\n\n" forall a. Semigroup a => a -> a -> a
<>
FilePath
"Explanation: This error message means that there is a bug in the " forall a. Semigroup a => a -> a -> a
<>
FilePath
"Dhall Documentation generator. You didn't did anything wrong, but " forall a. Semigroup a => a -> a -> a
<>
FilePath
"if you would like to see this problem fixed then you should report " forall a. Semigroup a => a -> a -> a
<>
FilePath
"the bug at:\n\n" forall a. Semigroup a => a -> a -> a
<>
FilePath
"https://github.com/dhall-lang/dhall-haskell/issues/new?labels=dhall-docs,bug\n\n" forall a. Semigroup a => a -> a -> a
<>
FilePath
"explaining your issue and add \"" forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
Data.Text.unpack Text
titleName forall a. Semigroup a => a -> a -> a
<> FilePath
"\" as error code " forall a. Semigroup a => a -> a -> a
<>
FilePath
"so we can find the proper location in the source code where the error happened\n\n" forall a. Semigroup a => a -> a -> a
<>
FilePath
"Please, also include your package in the issue. It can be in:\n\n" forall a. Semigroup a => a -> a -> a
<>
FilePath
"* A compressed archive (zip, tar, etc)\n" forall a. Semigroup a => a -> a -> a
<>
FilePath
"* A git repository, preferably with a commit reference"
generateDocs
:: Path Abs Dir
-> Path Abs Dir
-> Maybe Text
-> Text
-> CharacterSet
-> IO ()
generateDocs :: Path Abs Dir
-> Path Abs Dir -> Maybe Text -> Text -> CharacterSet -> IO ()
generateDocs Path Abs Dir
inputDir Path Abs Dir
outLink Maybe Text
baseImportUrl Text
packageName CharacterSet
characterSet = do
([Path Abs Dir]
_, [Path Abs File]
absFiles) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
Path.IO.listDirRecur Path Abs Dir
inputDir
[ByteString]
contents <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath -> IO ByteString
Data.ByteString.readFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> FilePath
Path.fromAbsFile) [Path Abs File]
absFiles
[Path Rel File]
strippedFiles <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
Path.stripProperPrefix Path Abs Dir
inputDir) [Path Abs File]
absFiles
let GeneratedDocs [DocsGenWarning]
warnings [(Path Rel File, Text)]
docs = Maybe Text
-> Text
-> CharacterSet
-> [(Path Rel File, ByteString)]
-> GeneratedDocs [(Path Rel File, Text)]
generateDocsPure Maybe Text
baseImportUrl Text
packageName CharacterSet
characterSet forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Path Rel File]
strippedFiles [ByteString]
contents
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. Show a => a -> IO ()
print [DocsGenWarning]
warnings
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Path Rel File, Text)]
docs then
FilePath -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$
FilePath
"No documentation was generated because no file with .dhall " forall a. Semigroup a => a -> a -> a
<>
FilePath
"extension was found"
else forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (Path Abs Dir -> m a) -> m a
Path.IO.withSystemTempDir FilePath
"dhall-docs" forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
tempDir -> do
Path Abs Dir -> IO ()
copyDataDir Path Abs Dir
tempDir
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Path Abs Dir -> (Path Rel File, Text) -> IO ()
writeGenFile Path Abs Dir
tempDir) [(Path Rel File, Text)]
docs
SHA256Digest
outputHash <- Path Abs Dir -> IO SHA256Digest
makeHashForDirectory Path Abs Dir
tempDir
Path Abs Dir
outDir <- forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
Applicative.liftA2 forall b t. Path b Dir -> Path Rel t -> Path b t
(</>)
IO (Path Abs Dir)
getDocsHomeDirectory
(forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
Path.parseRelDir
forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show SHA256Digest
outputHash forall a. Semigroup a => a -> a -> a
<> FilePath
"-" forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
Data.Text.unpack Text
packageName)
forall (m :: * -> *) b0 b1.
(MonadIO m, MonadCatch m) =>
Path b0 Dir -> Path b1 Dir -> m ()
Path.IO.copyDirRecur Path Abs Dir
tempDir Path Abs Dir
outDir
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 Dir -> Path b1 Dir -> m ()
Path.IO.createDirLink Path Abs Dir
outDir Path Abs Dir
outLink
where
writeGenFile :: Path Abs Dir -> (Path Rel File, Text) -> IO ()
writeGenFile :: Path Abs Dir -> (Path Rel File, Text) -> IO ()
writeGenFile Path Abs Dir
outDir (Path Rel File
relFile, Text
contents) = do
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
Path.IO.ensureDir (Path Abs Dir
outDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> forall b t. Path b t -> Path b Dir
Path.parent Path Rel File
relFile)
FilePath -> Text -> IO ()
Text.IO.writeFile (Path Abs File -> FilePath
Path.fromAbsFile forall a b. (a -> b) -> a -> b
$ Path Abs Dir
outDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile) Text
contents
copyDataDir :: Path Abs Dir -> IO ()
copyDataDir :: Path Abs Dir -> IO ()
copyDataDir Path Abs Dir
outDir = do
[(Path Rel File, ByteString)]
dataDir <- IO [(Path Rel File, ByteString)]
getDataDir
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
Control.Monad.forM_ [(Path Rel File, ByteString)]
dataDir forall a b. (a -> b) -> a -> b
$ \(Path Rel File
filename, ByteString
contents) -> do
let finalPath :: FilePath
finalPath = Path Abs File -> FilePath
Path.fromAbsFile forall a b. (a -> b) -> a -> b
$ Path Abs Dir
outDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
filename
FilePath -> ByteString -> IO ()
Data.ByteString.writeFile FilePath
finalPath ByteString
contents
generateDocsPure
:: Maybe Text
-> Text
-> CharacterSet
-> [(Path Rel File, ByteString)]
-> GeneratedDocs [(Path Rel File, Text)]
generateDocsPure :: Maybe Text
-> Text
-> CharacterSet
-> [(Path Rel File, ByteString)]
-> GeneratedDocs [(Path Rel File, Text)]
generateDocsPure Maybe Text
baseImportUrl Text
packageName CharacterSet
characterSet [(Path Rel File, ByteString)]
inputFiles = GeneratedDocs [(Path Rel File, Text)]
go
where
go :: GeneratedDocs [(Path Rel File, Text)]
go :: GeneratedDocs [(Path Rel File, Text)]
go = do
[RenderedFile]
renderedFiles <- [(Path Rel File, ByteString)] -> GeneratedDocs [RenderedFile]
getAllRenderedFiles [(Path Rel File, ByteString)]
inputFiles
[Text]
htmls <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe Text
-> Text -> CharacterSet -> RenderedFile -> GeneratedDocs Text
makeHtml Maybe Text
baseImportUrl Text
packageName CharacterSet
characterSet) [RenderedFile]
renderedFiles
let indexes :: [(Path Rel File, Text)]
indexes = Maybe Text
-> Text
-> CharacterSet
-> [RenderedFile]
-> [(Path Rel File, Text)]
createIndexes Maybe Text
baseImportUrl Text
packageName CharacterSet
characterSet [RenderedFile]
renderedFiles
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map (Path Rel File -> Path Rel File
addHtmlExt forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderedFile -> Path Rel File
path) [RenderedFile]
renderedFiles) [Text]
htmls forall a. Semigroup a => a -> a -> a
<> [(Path Rel File, Text)]
indexes)