{-# 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.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
instance Functor GeneratedDocs where
fmap f (GeneratedDocs w a) = GeneratedDocs w (f a)
instance Applicative GeneratedDocs where
pure = GeneratedDocs []
GeneratedDocs w f <*> GeneratedDocs w' a = GeneratedDocs (w <> w') (f a)
instance Monad GeneratedDocs where
GeneratedDocs w a >>= f =
let GeneratedDocs w' b = f a
in GeneratedDocs (w <> w') b
instance MonadWriter [DocsGenWarning] GeneratedDocs where
tell w = GeneratedDocs w ()
listen (GeneratedDocs w a) = GeneratedDocs w (a, w)
pass (GeneratedDocs w (a, f)) = GeneratedDocs (f w) a
data DocsGenWarning
= InvalidDhall (Text.Megaparsec.ParseErrorBundle Text Void)
| InvalidMarkdown MarkdownParseError
| DhallDocsCommentError (Path Rel File) CommentParseError
warn :: String
warn = "\n\ESC[1;33mWarning\ESC[0m: "
instance Show DocsGenWarning where
show (InvalidDhall err) =
warn <> "Invalid Input\n\n" <>
Text.Megaparsec.errorBundlePretty err <>
"... documentation won't be generated for this file"
show (InvalidMarkdown MarkdownParseError{..}) =
warn <>"Header comment is not markdown\n\n" <>
Text.Megaparsec.errorBundlePretty unwrap <>
"The original non-markdown text will be pasted in the documentation"
show (DhallDocsCommentError path err) =
warn <> Path.fromRelFile path <> specificError
where
specificError = case err of
MissingNewlineOnBlockComment -> ": After the `|` marker of a block comment " <>
"there must be a newline (either \\n or \\r\\n)"
SeveralSubseqDhallDocsComments -> ": Two dhall-docs comments in the same " <>
"comment section are forbidden"
BadSingleLineCommentsAlignment -> ": dhall-docs's single line comments " <>
"must be aligned"
BadPrefixesOnSingleLineComments -> ": dhall-docs's single line comments " <>
"must have specific prefixes:" <>
"* For the first line: \"--| \"\n" <>
"* For the rest of the linse: \"-- \""
newtype FileComments = FileComments
{ headerComment :: Maybe DhallDocsText
}
data DhallFile = DhallFile
{ path :: Path Rel File
, contents :: Text
, expr :: Expr Src Import
, mType :: Maybe (Expr Void Import)
, examples :: [Expr Void Import]
, fileComments :: FileComments
}
getAllDhallFiles :: [(Path Rel File, ByteString)] -> GeneratedDocs [DhallFile]
getAllDhallFiles = fmap Maybe.catMaybes . mapM toDhallFile . foldr validFiles [] . filter hasDhallExtension
where
hasDhallExtension :: (Path Rel File, a) -> Bool
hasDhallExtension (absFile, _) = case Path.splitExtension absFile of
Nothing -> False
Just (_, ext) -> ext == ".dhall"
validFiles :: (Path Rel File, ByteString) -> [(Path Rel File, Text)] -> [(Path Rel File, Text)]
validFiles (relFile, content) xs = case Data.Text.Encoding.decodeUtf8' content of
Left _ -> xs
Right textContent -> (relFile, textContent) : xs
toDhallFile :: (Path Rel File, Text) -> GeneratedDocs (Maybe DhallFile)
toDhallFile (relFile, contents) =
case exprAndHeaderFromText (Path.fromRelFile relFile) contents of
Right (Header header, expr) -> do
let denoted = denote expr :: Expr Void Import
headerContents <-
case parseSingleDhallDocsComment (Path.fromRelFile relFile) header of
Nothing -> return Nothing
Just (Left errs) -> do
Writer.tell $ map (DhallDocsCommentError relFile) errs
return Nothing
Just (Right c) -> return $ Just c
return $ Just $ DhallFile
{ expr, contents
, path = relFile
, mType = extractTypeIfInSource denoted
, examples = examplesFromAssertions denoted
, fileComments = FileComments headerContents
}
Left ParseError{..} -> do
Writer.tell [InvalidDhall unwrap]
return Nothing
bindings :: Expr Void Import -> [Binding Void Import]
bindings expr = case expr of
Let b@Binding{} e ->
let MultiLet bs _ = Dhall.Core.multiLet b e
in NonEmpty.toList bs
_ -> []
extractTypeIfInSource :: Expr Void Import -> Maybe (Expr Void Import)
extractTypeIfInSource expr =
fromOrdinaryAnnotation expr
<|> fromLetBindingAnnotation
where
fromOrdinaryAnnotation (Let _ e) = fromOrdinaryAnnotation e
fromOrdinaryAnnotation (Annot _ _T) = pure _T
fromOrdinaryAnnotation _ = empty
fromLetBindingAnnotation = do
V name index <- maybeNameInLet expr
(Binding _ _ _ (Just (_, exprType)) _ _) <-
getLetBindingWithIndex index $ getLetBindingsWithName name
return exprType
maybeNameInLet :: Expr Void Import -> Maybe Var
maybeNameInLet (Var v@(V _ _)) = Just v
maybeNameInLet (Let _ e) = maybeNameInLet e
maybeNameInLet _ = Nothing
getLetBindingsWithName :: Text -> [Binding Void Import]
getLetBindingsWithName name = filter bindName $ reverse $ bindings expr
where
bindName (Binding _ x _ _ _ _) = x == name
getLetBindingWithIndex :: Int -> [Binding Void Import] -> Maybe (Binding Void Import)
getLetBindingWithIndex i bs =
case drop i bs of
[] -> Nothing
binding : _ -> Just binding
examplesFromAssertions :: Expr Void Import -> [Expr Void Import]
examplesFromAssertions expr = Maybe.mapMaybe fromAssertion values
where
values :: [Expr Void Import]
values = map value $ bindings expr
fromAssertion :: Expr Void Import -> Maybe (Expr Void Import)
fromAssertion (Assert e) = Just e
fromAssertion _ = Nothing
resolveRelativePath :: Path Rel Dir -> FilePath
resolveRelativePath currentDir =
case FilePath.dropTrailingPathSeparator $ Path.fromRelDir currentDir of
"." -> ""
_ -> "../" <> resolveRelativePath (Path.parent currentDir)
makeHtml
:: Text
-> CharacterSet
-> DhallFile
-> GeneratedDocs Text
makeHtml packageName characterSet DhallFile {..} = do
let relativeResourcesPath = resolveRelativePath $ Path.parent path
let strippedHeader = Maybe.maybe "" unDhallDocsText (headerComment fileComments)
headerAsHtml <-
case markdownToHtml path strippedHeader of
Left err -> do
Writer.tell [InvalidMarkdown err]
return $ Lucid.toHtml strippedHeader
Right html -> return html
let htmlAsText = Text.Lazy.toStrict $ Lucid.renderText $ dhallFileToHtml
path
contents
expr
examples
headerAsHtml
DocParams { relativeResourcesPath, packageName, characterSet }
return htmlAsText
createIndexes :: Text -> CharacterSet -> [DhallFile] -> [(Path Rel File, Text)]
createIndexes packageName characterSet files = map toIndex dirToDirsAndFilesMapAssocs
where
dirToFilesMap :: Map (Path Rel Dir) [DhallFile]
dirToFilesMap = Map.unionsWith (<>) $ map toMap $ Data.List.sortBy (compare `on` path) files
where
toMap :: DhallFile -> Map (Path Rel Dir) [DhallFile]
toMap dhallFile = Map.singleton (Path.parent $ path dhallFile) [dhallFile]
dirToDirsMap :: Map (Path Rel Dir) [Path Rel Dir]
dirToDirsMap = Map.map removeHereDir $ foldr go initialMap dirs
where
removeHereDir :: [Path Rel Dir] -> [Path Rel Dir]
removeHereDir = filter f
where
f :: Path Rel Dir -> Bool
f reldir = Path.parent reldir /= reldir
dirs :: [Path Rel Dir]
dirs = Map.keys dirToFilesMap
initialMap :: Map (Path Rel Dir) [Path Rel Dir]
initialMap = Map.fromList $ map (,[]) dirs
go :: Path Rel Dir -> Map (Path Rel Dir) [Path Rel Dir] -> Map (Path Rel Dir) [Path Rel Dir]
go d dirMap = Map.adjust ([d] <>) (key $ Path.parent d) dirMap
where
key :: Path Rel Dir -> Path Rel Dir
key dir = if dir `Map.member` dirMap then dir else key $ Path.parent dir
dirToDirsAndFilesMapAssocs :: [(Path Rel Dir, ([DhallFile], [Path Rel Dir]))]
dirToDirsAndFilesMapAssocs = Map.assocs $ Map.mapWithKey f dirToFilesMap
where
f :: Path Rel Dir -> [DhallFile] -> ([DhallFile], [Path Rel Dir])
f dir dhallFiles = case dirToDirsMap Map.!? dir of
Nothing -> fileAnIssue "dirToDirsAndFilesMapAssocs"
Just dirs -> (dhallFiles, dirs)
toIndex :: (Path Rel Dir, ([DhallFile], [Path Rel Dir])) -> (Path Rel File, Text)
toIndex (indexDir, (dhallFiles, dirs)) =
(indexDir </> $(Path.mkRelFile "index.html"), Text.Lazy.toStrict $ Lucid.renderText html)
where
html = indexToHtml
indexDir
(map (\DhallFile{..} -> (stripPrefix $ addHtmlExt path, mType)) dhallFiles)
(map stripPrefix dirs)
DocParams { relativeResourcesPath = resolveRelativePath indexDir, packageName, characterSet }
stripPrefix :: Path Rel a -> Path Rel a
stripPrefix relpath =
if Path.toFilePath relpath == Path.toFilePath indexDir then relpath
else Data.Maybe.fromMaybe (fileAnIssue "Bug+with+stripPrefix")
$ Path.stripProperPrefix indexDir relpath
addHtmlExt :: Path Rel File -> Path Rel File
addHtmlExt relFile =
Data.Maybe.fromMaybe (fileAnIssue "addHtmlExt") $ Path.addExtension ".html" relFile
fileAnIssue :: Text -> a
fileAnIssue titleName =
error $ "\ESC[1;31mError\ESC[0m Documentation generator bug\n\n" <>
"Explanation: This error message means that there is a bug in the " <>
"Dhall Documentation generator. You didn't did anything wrong, but " <>
"if you would like to see this problem fixed then you should report " <>
"the bug at:\n\n" <>
"https://github.com/dhall-lang/dhall-haskell/issues/new?labels=dhall-docs,bug\n\n" <>
"explaining your issue and add \"" <> Data.Text.unpack titleName <> "\" as error code " <>
"so we can find the proper location in the source code where the error happened\n\n" <>
"Please, also include your package in the issue. It can be in:\n\n" <>
"* A compressed archive (zip, tar, etc)\n" <>
"* A git repository, preferably with a commit reference"
generateDocs
:: Path Abs Dir
-> Path Abs Dir
-> Text
-> CharacterSet
-> IO ()
generateDocs inputDir outLink packageName characterSet = do
(_, absFiles) <- Path.IO.listDirRecur inputDir
contents <- mapM (Data.ByteString.readFile . Path.fromAbsFile) absFiles
strippedFiles <- mapM (Path.stripProperPrefix inputDir) absFiles
let GeneratedDocs warnings docs = generateDocsPure packageName characterSet $ zip strippedFiles contents
mapM_ print warnings
if null docs then
putStrLn $
"No documentation was generated because no file with .dhall " <>
"extension was found"
else Path.IO.withSystemTempDir "dhall-docs" $ \tempDir -> do
copyDataDir tempDir
mapM_ (writeGenFile tempDir) docs
outputHash <- makeHashForDirectory tempDir
outDir <- Applicative.liftA2 (</>)
getDocsHomeDirectory
(Path.parseRelDir
$ show outputHash <> "-" <> Data.Text.unpack packageName)
Path.IO.copyDirRecur tempDir outDir
Path.IO.createDirLink outDir outLink
where
writeGenFile :: Path Abs Dir -> (Path Rel File, Text) -> IO ()
writeGenFile outDir (relFile, contents) = do
Path.IO.ensureDir (outDir </> Path.parent relFile)
Text.IO.writeFile (Path.fromAbsFile $ outDir </> relFile) contents
copyDataDir :: Path Abs Dir -> IO ()
copyDataDir outDir = do
dataDir <- getDataDir
Control.Monad.forM_ dataDir $ \(filename, contents) -> do
let finalPath = Path.fromAbsFile $ outDir </> filename
Data.ByteString.writeFile finalPath contents
generateDocsPure
:: Text
-> CharacterSet
-> [(Path Rel File, ByteString)]
-> GeneratedDocs [(Path Rel File, Text)]
generateDocsPure packageName characterSet inputFiles = go
where
go :: GeneratedDocs [(Path Rel File, Text)]
go = do
dhallFiles <- getAllDhallFiles inputFiles
htmls <- mapM (makeHtml packageName characterSet) dhallFiles
let indexes = createIndexes packageName characterSet dhallFiles
return (zip (map (addHtmlExt . path) dhallFiles) htmls <> indexes)