diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +0.0.1 + +* Project skeleton with command line options diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2020 Gabriel Gonzalez +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/dhall-docs.cabal b/dhall-docs.cabal new file mode 100644 --- /dev/null +++ b/dhall-docs.cabal @@ -0,0 +1,133 @@ +Name: dhall-docs +Version: 0.0.1 +Cabal-Version: >=1.10 +Build-Type: Simple +Tested-With: GHC == 8.6.1 +License: BSD3 +License-File: LICENSE +Copyright: 2020 Germán Robayo +Author: Germán Robayo +Maintainer: Gabriel439@gmail.com +Bug-Reports: https://github.com/dhall-lang/dhall-haskell/issues +Synopsis: Generate HTML docs from a dhall package +Description: + Use this package if you want to create HTML documentation from your dhall + packages: + . + * See the "Dhall.Docs" module if you want to use this package as a library + . + * Use the @dhall-docs@ program from this package if you want an executable + . + The "Dhall.Docs" module also contains instructions for how to use this package +Category: Compiler +Extra-Source-Files: + CHANGELOG.md + tasty/data/package/*.dhall + tasty/data/package/a/*.dhall + tasty/data/package/a/b/*.dhall + tasty/data/package/a/b/c/*.dhall + tasty/data/package/deep/nested/folder/*.dhall + tasty/data/golden/*.dhall.html + tasty/data/golden/a/*.dhall.html + tasty/data/golden/a/b/*.dhall.html + tasty/data/golden/a/b/c/*.dhall.html + tasty/data/golden/deep/nested/folder/*.dhall.html + tasty/data/golden/*.html + tasty/data/golden/a/*.html + tasty/data/golden/a/b/*.html + tasty/data/golden/a/b/c/*.html + tasty/data/golden/deep/nested/folder/*.html +Data-Files: + *.css + *.js + *.svg +Data-Dir: + src/Dhall/data + +Source-Repository head + Type: git + Location: https://github.com/dhall-lang/dhall-haskell/tree/master/dhall-json + + +Flag ghci-data-files + description: To enable use of data-files while running `stack ghci` + default: False + +Library + Hs-Source-Dirs: src + Build-Depends: + base >= 4.9.1.0 && < 5 , + bytestring < 0.11, + containers , + directory >= 1.3.0.0 && < 1.4 , + dhall >= 1.32.0 , + file-embed >= 0.0.10.0 , + filepath >= 1.4 && < 1.5 , + lucid >= 2.9.12 && < 2.10, + mmark >= 0.0.7.0 && < 0.8 , + megaparsec >= 7 && < 8.1 , + path >= 0.7.0 && < 0.8 , + path-io >= 1.6.0 && < 1.7 , + prettyprinter >= 1.5.1 && < 1.7 , + tar >= 0.5.1.0 && < 0.6 , + text >= 0.11.1.0 && < 1.3 , + mtl >= 2.2.1 && < 2.3 , + optparse-applicative >= 0.14.0.0 && < 0.16 + Exposed-Modules: + Dhall.Docs + Dhall.Docs.Core + Other-Modules: + Dhall.Docs.Embedded + Dhall.Docs.Html + Dhall.Docs.Markdown + Dhall.Docs.Store + Paths_dhall_docs + GHC-Options: -Wall + Default-Language: Haskell2010 + if flag(ghci-data-files) + Other-Modules: Paths_dhall_docs + else + Cpp-Options: "-DEMBED" + +Executable dhall-docs + Hs-Source-Dirs: dhall-docs + Main-Is: Main.hs + Build-Depends: + base , + dhall , + dhall-docs + Other-Modules: + Paths_dhall_docs + GHC-Options: -Wall + Default-Language: Haskell2010 + +Test-Suite doctest + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: doctest + Main-Is: Main.hs + GHC-Options: -Wall + Build-Depends: + base , + directory, + filepath < 1.5 , + doctest >= 0.7.0 && < 0.18 + Other-Extensions: OverloadedStrings RecordWildCards + Default-Language: Haskell2010 + +Test-Suite tasty + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: tasty + Main-Is: Main.hs + Build-Depends: + base , + containers , + dhall-docs , + HaXml >= 1.25.5 , + path , + path-io , + pretty >= 1.1.1.1, + tasty < 1.4 , + tasty-silver <= 3.1.15 , + text + GHC-Options: -Wall + Default-Language: Haskell2010 diff --git a/dhall-docs/Main.hs b/dhall-docs/Main.hs new file mode 100644 --- /dev/null +++ b/dhall-docs/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import qualified Dhall.Docs + +main :: IO () +main = Dhall.Docs.main diff --git a/doctest/Main.hs b/doctest/Main.hs new file mode 100644 --- /dev/null +++ b/doctest/Main.hs @@ -0,0 +1,18 @@ +module Main where + +import System.FilePath (()) + +import qualified GHC.IO.Encoding +import qualified System.Directory +import qualified System.IO +import qualified Test.DocTest + +main :: IO () +main = do + GHC.IO.Encoding.setLocaleEncoding System.IO.utf8 + pwd <- System.Directory.getCurrentDirectory + prefix <- System.Directory.makeAbsolute pwd + Test.DocTest.doctest + [ "--fast" + , prefix "src" + ] diff --git a/src/Dhall/Docs.hs b/src/Dhall/Docs.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Docs.hs @@ -0,0 +1,132 @@ +{-| This module contains the top level and options parsing of the @dhall-docs@ + executable +-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Dhall.Docs + ( -- * Options + Options(..) + , parserInfoOptions + , parseOptions + + -- * Execution + , main + , defaultMain + ) where + +import Control.Applicative ((<|>)) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Version (showVersion) +import Dhall.Docs.Core +import Options.Applicative (Parser, ParserInfo) +import Path (Abs, Dir, Path) + +import qualified Control.Monad +import qualified Data.Text +import qualified Data.Text.IO as Text.IO +import qualified GHC.IO.Encoding +import qualified Options.Applicative +import qualified Path +import qualified Path.IO +import qualified Paths_dhall_docs as Meta +import qualified System.Directory +import qualified System.Exit +import qualified System.IO + +-- | Command line options +data Options + = Options + { packageDir :: FilePath -- ^ Directory where your package resides + , docLink :: FilePath -- ^ Link to the generated documentation + , resolvePackageName :: Path Abs Dir -> Text + } + | Version + +-- | `Parser` for the `Options` type +parseOptions :: Parser Options +parseOptions = + ( Options + <$> Options.Applicative.strOption + ( Options.Applicative.long "input" + <> Options.Applicative.metavar "INPUT" + <> Options.Applicative.help "Directory of your dhall package" ) + <*> Options.Applicative.strOption + ( Options.Applicative.long "output-link" + <> Options.Applicative.metavar "OUTPUT-LINK" + <> Options.Applicative.help + ( "Path to the link targeting the directory with the generated " + <> "documentation. The path needs to not exist or to be a symlink, " + <> "otherwise the tool won't generate any docs at all" + ) + <> Options.Applicative.value "./docs" ) + <*> parsePackageNameResolver + ) <|> parseVersion + where + parseVersion = + Options.Applicative.flag' + Version + ( Options.Applicative.long "version" + <> Options.Applicative.help "Display version" + ) + + parsePackageNameResolver :: Parser (Path Abs Dir -> Text) + parsePackageNameResolver = fmap f (Options.Applicative.optional p) + where + -- Directories on the `path` modules always ends in "/", so we have + -- to remove last one with `init` + f Nothing = Data.Text.pack . init . Path.fromRelDir . Path.dirname + f (Just packageName) = const $ Data.Text.pack packageName + + p = Options.Applicative.strOption + ( Options.Applicative.long "package-name" + <> Options.Applicative.metavar "PACKAGE-NAME" + <> Options.Applicative.help + ( "Override for the package name seen on HTML " + <> "navbars. By default, it will extract it from " + <> "the input" + ) + ) + +-- | `ParserInfo` for the `Options` type +parserInfoOptions :: ParserInfo Options +parserInfoOptions = + let progDesc = "Generate HTML documentation from a dhall package or file" in + Options.Applicative.info + (Options.Applicative.helper <*> parseOptions) + ( Options.Applicative.fullDesc + <> Options.Applicative.progDesc progDesc + ) + + +-- | Default execution of @dhall-docs@ command +defaultMain :: Options -> IO () +defaultMain = \case + Options{..} -> do + GHC.IO.Encoding.setLocaleEncoding System.IO.utf8 + resolvedPackageDir <- Path.IO.resolveDir' packageDir + + outDirExists <- System.Directory.doesPathExist docLink + Control.Monad.when outDirExists $ do + isLink <- System.Directory.pathIsSymbolicLink docLink + if isLink then System.Directory.removeFile docLink + else die $ "The specified --output-link (" <> Data.Text.pack docLink + <> ") already exists and it's not a symlink." + + resolvedDocLink <- Path.IO.resolveDir' docLink + let packageName = resolvePackageName resolvedPackageDir + generateDocs resolvedPackageDir resolvedDocLink packageName + Version -> + putStrLn (showVersion Meta.version) + +die :: Text -> IO a +die e = do + Text.IO.hPutStrLn System.IO.stderr e + + System.Exit.exitFailure + +-- | Entry point for the @dhall-docs@ executable +main :: IO () +main = Options.Applicative.execParser parserInfoOptions >>= defaultMain diff --git a/src/Dhall/Docs/Core.hs b/src/Dhall/Docs/Core.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Docs/Core.hs @@ -0,0 +1,435 @@ +{-| Contains all the functions that generate documentation + + We should always try to do as little work as possible in an `IO` context. + To do so, just wrap your function in `IO` if you need to do I/O operations, + and make pure functions receive that IO result as an input +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +-- {-# OPTIONS_GHC -Wno-unused-imports #-} + +module Dhall.Docs.Core (generateDocs, generateDocsPure, GeneratedDocs(..)) where + +import Control.Monad.Writer.Class (MonadWriter) +import Data.Function (on) +import Data.Map.Strict (Map) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Core + ( Binding (..) + , Expr (..) + , Import + , MultiLet (..) + , Var (..) + , denote + ) +import Dhall.Docs.Embedded +import Dhall.Docs.Html +import Dhall.Docs.Markdown +import Dhall.Docs.Store +import Dhall.Parser + ( Header (..) + , ParseError (..) + , exprAndHeaderFromText + ) +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.Either +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.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 + +-- $setup +-- >>> :set -XQuasiQuotes +-- >>> import Path (reldir) + +-- | The result of the doc-generator pure component +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 + +instance Show DocsGenWarning where + show (InvalidDhall err) = + "\n\ESC[1;33mWarning\ESC[0m: Invalid Input\n\n" <> + Text.Megaparsec.errorBundlePretty err <> + "... documentation won't be generated for this file" + + show (InvalidMarkdown MarkdownParseError{..}) = + "\n\ESC[1;33mWarning\ESC[0m: Header comment is not markdown\n\n" <> + Text.Megaparsec.errorBundlePretty unwrap <> + "The original non-markdown text will be pasted in the documentation" + +-- | Represents a Dhall file that can be rendered as documentation. +-- If you'd like to improve or add features to a .dhall documentation page, +-- add that extra information here. +data DhallFile = DhallFile + { path :: Path Rel File -- ^ Path of the file + , expr :: Expr Src Import -- ^ File contents + , header :: Header -- ^ Parsed `Header` of the file + , mType :: Maybe (Expr Void Import) -- ^ Type of the parsed expression, + -- extracted from the source code + , examples :: [Expr Void Import] -- ^ Examples extracted from assertions + -- in the file + } + +{-| Takes a list of files paths with their contents and returns the list of + valid `DhallFile`s. + + Returned files contains all the information to be used on `Html ()` + generation. + + The result is sorted by `path` +-} +getAllDhallFiles :: [(Path Rel File, Text)] -> GeneratedDocs [DhallFile] +getAllDhallFiles = emitErrors . map toDhallFile . filter hasDhallExtension + where + hasDhallExtension :: (Path Rel File, Text) -> Bool + hasDhallExtension (absFile, _) = case Path.splitExtension absFile of + Nothing -> False + Just (_, ext) -> ext == ".dhall" + + toDhallFile :: (Path Rel File, Text) -> Either DocsGenWarning DhallFile + toDhallFile (relFile, contents) = + case exprAndHeaderFromText (Path.fromRelFile relFile) contents of + Right (header, expr) -> + let denoted = denote expr :: Expr Void Import in + Right DhallFile + { path = relFile + , expr, header + , mType = extractTypeIfInSource denoted + , examples = examplesFromAssertions denoted + } + Left ParseError{..} -> + Left $ InvalidDhall unwrap + + emitErrors :: [Either DocsGenWarning DhallFile] -> GeneratedDocs [DhallFile] + emitErrors errorsOrDhallFiles = do + let (errors, dhallFiles) = Data.Either.partitionEithers errorsOrDhallFiles + Writer.tell errors + let sortedDhallFiles = Data.List.sortBy (compare `on` path) dhallFiles + return sortedDhallFiles + + 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 = do + V name index <- maybeNameInLet expr + (Binding _ _ _ (Just (_, exprType)) _ _) <- + getLetBindingWithIndex index $ getLetBindingsWithName name + return exprType + where + -- | For an expression of the form @let x0 = y0 let x1 = y1 ... in e@ + -- where @e@ is a variable, maybeNameInLet returns the variable name. + maybeNameInLet :: Expr Void Import -> Maybe Var + maybeNameInLet (Var v@(V _ _)) = Just v + maybeNameInLet (Let _ e) = maybeNameInLet e + maybeNameInLet _ = Nothing + + + {-| For an expression of the form @let x0 = y0 x1 = y1 ... in e@ + and a variable name @v@, this returns every @xi@ that is equal to + v in the reverse order of the source code. + + For example, take a file like this: + + > let x = 1 + > let y = 2 + > let z = 3 + > in x + y + z + + ... this will return the bindings in this order: [z, y, x] + + Only the "global" level of the file is analyzed + -} + 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 + +{-| Given a relative path, returns as much @..\/@ misdirections as needed + to go to @.@ + +>>> resolveRelativePath [reldir|.|] +"" +>>> resolveRelativePath [reldir|a|] +"../" +>>> resolveRelativePath [reldir|a/b/c|] +"../../../" +-} +resolveRelativePath :: Path Rel Dir -> FilePath +resolveRelativePath currentDir = + case FilePath.dropTrailingPathSeparator $ Path.fromRelDir currentDir of + "." -> "" + _ -> "../" <> resolveRelativePath (Path.parent currentDir) + +{-| Generates `Text` from the html representation of a `DhallFile` +-} +makeHtml + :: Text -- ^ Package name + -> DhallFile -- ^ Parsed header + -> GeneratedDocs Text +makeHtml packageName DhallFile {..} = do + let relativeResourcesPath = resolveRelativePath $ Path.parent path + let strippedHeader = stripCommentSyntax header + 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 + expr + examples + headerAsHtml + DocParams { relativeResourcesPath, packageName } + + return htmlAsText + where + stripCommentSyntax :: Header -> Text + stripCommentSyntax (Header h) + | Just s <- Data.Text.stripPrefix "--" strippedHeader + = Data.Text.strip s + | Just commentPrefixStripped <- Data.Text.stripPrefix "{-" strippedHeader + , Just commentSuffixStripped <- Data.Text.stripSuffix "-}" commentPrefixStripped + = Data.Text.strip commentSuffixStripped + | otherwise = strippedHeader + where + strippedHeader = Data.Text.strip h + +{-| Create an @index.html@ file on each available folder in the input. + + Each @index.html@ lists the files and directories of its directory. Listed + directories will be compacted as much as it cans to improve readability. + + For example, take the following directory-tree structure + + > . + > ├── a + > │ └── b + > │ └── c + > │ └── b.dhall + > └── a.dhall + + To improve navigation, the index at @./index.html@ should list + @a/b/c@ and no @index.html@ should be generated inside of `a/` or + `a/b/`, but yes on `a/b/c/` in the last one there is the @b.dhall@ file +-} +createIndexes :: Text -> [DhallFile] -> [(Path Rel File, Text)] +createIndexes packageName files = map toIndex dirToDirsAndFilesMapAssocs + where + -- Files grouped by their directory + dirToFilesMap :: Map (Path Rel Dir) [DhallFile] + dirToFilesMap = Map.unionsWith (<>) $ map toMap files + where + toMap :: DhallFile -> Map (Path Rel Dir) [DhallFile] + toMap dhallFile = + Map.singleton (Path.parent $ path dhallFile) [dhallFile] + + {- This is used to compute the list of exported packages on each folder. + We try to compress the folders as much as we can. See `createIndexes` + documentation to get more information. + -} + dirToDirsMap :: Map (Path Rel Dir) [Path Rel Dir] + dirToDirsMap = Map.map removeHereDir $ foldl go initialMap dirs + where + -- > removeHeredir [$(mkRelDir "a"), $(mkRelDir ".")] + -- [$(mkRelDir "a")] + 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 :: Map (Path Rel Dir) [Path Rel Dir] -> Path Rel Dir -> Map (Path Rel Dir) [Path Rel Dir] + go dirMap d = 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 } + + 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 + +-- | Takes a file and adds an @.html@ file extension to it +addHtmlExt :: Path Rel File -> Path Rel File +addHtmlExt relFile = + Data.Maybe.fromMaybe (fileAnIssue "addHtmlExt") $ Path.addExtension ".html" relFile + +-- | If you're wondering the GitHub query params for issue creation: +-- https://docs.github.com/en/github/managing-your-work-on-github/about-automation-for-issues-and-pull-requests-with-query-parameters +fileAnIssue :: Text -> a +fileAnIssue titleName = + error $ "\ESC[1;31mError\ESC[0mDocumentation 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" + +{-| Generate all of the docs for a package. This function does all the `IO ()` + related tasks to call `generateDocsPure` +-} +generateDocs + :: Path Abs Dir -- ^ Input directory + -> Path Abs Dir -- ^ Link to be created to the generated documentation + -> Text -- ^ Package name, used in some HTML titles + -> IO () +generateDocs inputDir outLink packageName = do + (_, absFiles) <- Path.IO.listDirRecur inputDir + contents <- mapM (Text.IO.readFile . Path.fromAbsFile) absFiles + strippedFiles <- mapM (Path.stripProperPrefix inputDir) absFiles + let GeneratedDocs warnings docs = generateDocsPure packageName $ 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 + +{-| Generates all the documentation of dhall package in a pure way i.e. + without an `IO` context. This let you generate documentation from a list of + dhall-files without saving them to the filesystem. + + If you want the `IO` version of this function, check `generateDocs` +-} +generateDocsPure + :: Text -- ^ Package name + -> [(Path Rel File, Text)] -- ^ (Input file, contents) + -> GeneratedDocs [(Path Rel File, Text)] +generateDocsPure packageName inputFiles = go + where + go :: GeneratedDocs [(Path Rel File, Text)] + go = do + dhallFiles <- getAllDhallFiles inputFiles + htmls <- mapM (makeHtml packageName) dhallFiles + let indexes = createIndexes packageName dhallFiles + return (zip (map (addHtmlExt . path) dhallFiles) htmls <> indexes) + diff --git a/src/Dhall/Docs/Embedded.hs b/src/Dhall/Docs/Embedded.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Docs/Embedded.hs @@ -0,0 +1,45 @@ +{-| Compile-time generated files, used to put all data-files in the executable + to make it easy to distribute. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module Dhall.Docs.Embedded (getDataDir) where + +import Data.ByteString (ByteString) +import Path (File, Path, Rel) + +import qualified Path + +#if defined(EMBED) + +import Data.FileEmbed (embedDir) + +#else + +import Paths_dhall_docs hiding (getDataDir) + +import qualified Control.Monad +import qualified Data.ByteString as ByteString +import qualified Path.IO + +#endif + +getDataDir :: IO [(Path Rel File, ByteString)] +#if defined(EMBED) +getDataDir = return $(embedDir "src/Dhall/data") >>= mapM f + where + f :: (FilePath, ByteString) -> IO (Path Rel File, ByteString) + f (filePath, contents) = (,contents) <$> Path.parseRelFile filePath +#else +getDataDir = do + dir <- Path.parent + <$> (getDataFileName "src/Dhall/data/index.css" >>= Path.parseAbsFile) + files <- snd <$> Path.IO.listDir dir + Control.Monad.forM files $ \file -> do + contents <- ByteString.readFile $ Path.fromAbsFile file + return (Path.filename file, contents) + +#endif diff --git a/src/Dhall/Docs/Html.hs b/src/Dhall/Docs/Html.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Docs/Html.hs @@ -0,0 +1,298 @@ +{-| Functions used to generate HTML from a dhall package. + You can see this module as logic-less HTML building blocks for the whole + generator tool. + + There are functions that uses `FilePath` instead of `Path a b`. That is because + the `Path` module doesn't allows to use ".." on its paths and that is needed + here to properly link css and images. +-} + +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Dhall.Docs.Html + ( dhallFileToHtml + , indexToHtml + , DocParams(..) + ) where + +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Core (Expr, Import) +import Dhall.Pretty (Ann (..)) +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 Data.Text.Prettyprint.Doc as Pretty +import qualified Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree as Pretty +import qualified Dhall.Pretty +import qualified Path +import qualified System.FilePath as FilePath + +-- $setup +-- >>> :set -XQuasiQuotes +-- >>> import Path (reldir, relfile) + +-- | Internal utility to differentiate if a Dhall expr is a type annotation +-- or the whole file +data ExprType = TypeAnnotation | FileContentsExpr + + +exprToHtml :: ExprType -> Expr a Import -> Html () +exprToHtml exprType expr = pre_ $ renderTree prettyTree + where + layout = case exprType of + FileContentsExpr -> Dhall.Pretty.layout + TypeAnnotation -> typeLayout + + prettyTree = Pretty.treeForm + $ layout + $ Dhall.Pretty.prettyExpr expr + + textSpaces :: Int -> Text + textSpaces n = Data.Text.replicate n (Data.Text.singleton ' ') + + renderTree :: Pretty.SimpleDocTree Ann -> Html () + renderTree sds = case sds of + Pretty.STEmpty -> return () + Pretty.STChar c -> toHtml $ Data.Text.singleton c + Pretty.STText _ t -> toHtml t + Pretty.STLine i -> br_ [] >> toHtml (textSpaces i) + Pretty.STAnn ann content -> encloseInTagFor ann (renderTree content) + Pretty.STConcat contents -> foldMap renderTree contents + + encloseInTagFor :: Ann -> Html () -> Html () + encloseInTagFor ann = span_ [class_ classForAnn] + where + classForAnn = "dhall-" <> case ann of + Keyword -> "keyword" + Syntax -> "syntax" + Label -> "label" + Literal -> "literal" + Builtin -> "builtin" + Operator -> "operator" + + typeLayout :: Pretty.Doc ann -> Pretty.SimpleDocStream ann + typeLayout = Pretty.removeTrailingWhitespace . Pretty.layoutSmart opts + where + -- this is done so the type of a dhall file fits in a single line + -- its a safe value, since types in source codes are not that large + opts :: Pretty.LayoutOptions + opts = Pretty.defaultLayoutOptions + { Pretty.layoutPageWidth = + Pretty.Unbounded + } + + +-- | Params for commonly supplied values on the generated documentation +data DocParams = DocParams + { relativeResourcesPath :: FilePath -- ^ Relative resource path to the + -- front-end files + , packageName :: Text -- ^ Name of the package + } + +-- | Generates an @`Html` ()@ with all the information about a dhall file +dhallFileToHtml + :: Path Rel File -- ^ Source file name, used to extract the title + -> Expr Src Import -- ^ Contents of the file + -> [Expr Void Import] -- ^ Examples extracted from the assertions of the file + -> Html () -- ^ Header document as HTML + -> DocParams -- ^ Parameters for the documentation + -> Html () +dhallFileToHtml filePath 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_ (exprToHtml FileContentsExpr) examples + h3_ "Source" + div_ [class_ "source-code"] $ exprToHtml FileContentsExpr expr + where + breadcrumb = relPathToBreadcrumb filePath + htmlTitle = breadCrumbsToText breadcrumb + +-- | Generates an index @`Html` ()@ that list all the dhall files in that folder +indexToHtml + :: Path Rel Dir -- ^ Index directory + -> [(Path Rel File, Maybe (Expr Void Import))] -- ^ Generated files in that directory + -> [Path Rel Dir] -- ^ Generated directories in that directory + -> DocParams -- ^ Parameters for the documentation + -> 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"] $ exprToHtml 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 + + +-- | ADT for handling bread crumbs. This is essentially a backwards list +-- See `relPathToBreadcrumb` for more information. +data Breadcrumb + = Crumb Breadcrumb String + | EmptyCrumb + deriving Show + +data HtmlFileType = NotIndex | Index + +{-| Convert a relative path to a `Breadcrumb`. + +>>> relPathToBreadcrumb [reldir|a/b/c|] +Crumb (Crumb (Crumb EmptyCrumb "a") "b") "c" +>>> relPathToBreadcrumb [reldir|.|] +Crumb EmptyCrumb "" +>>> relPathToBreadcrumb [relfile|c/foo.baz|] +Crumb (Crumb EmptyCrumb "c") "foo.baz" +-} +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 + +-- | Render breadcrumbs as `Html ()` +breadCrumbsToHtml :: HtmlFileType -> Breadcrumb -> Html () +breadCrumbsToHtml htmlFileType = go startLevel + where + startLevel = case htmlFileType of + NotIndex -> -1 + Index -> 0 + + -- copyBreadcrumbButton :: Html () + -- copyBreadcrumbButton = + -- button_ + -- [ class_ "btn copy-breadcrumb" + -- , data_ "breadcrumb" $ breadCrumbsToText breadcrumb + -- ] "" + + 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_ + + +-- | Render breadcrumbs as plain text +breadCrumbsToText :: Breadcrumb -> Text +breadCrumbsToText EmptyCrumb = "" +breadCrumbsToText (Crumb bc c) = breadCrumbsToText bc <> "/" <> Data.Text.pack c + + +-- | nav-bar component of the HTML documentation +navBar + :: DocParams -- ^ Parameters for doc generation + -> Html () +navBar DocParams{..} = div_ [class_ "nav-bar"] $ do + + -- Left side of the nav-bar + img_ [ class_ "dhall-icon" + , src_ $ Data.Text.pack $ relativeResourcesPath <> "dhall-icon.svg" + ] + p_ [class_ "package-title"] $ toHtml packageName + + div_ [class_ "nav-bar-content-divider"] "" + + -- Right side of the nav-bar + -- with makeOption [id_ "go-to-source-code"] "Source code" + 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&display=swap" + script relativeResourcesPath + meta_ [charset_ "UTF-8"] + +-- | main-container component builder of the HTML documentation +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) diff --git a/src/Dhall/Docs/Markdown.hs b/src/Dhall/Docs/Markdown.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Docs/Markdown.hs @@ -0,0 +1,32 @@ +{-| Contains all utilities related to markdown processing +-} +module Dhall.Docs.Markdown + ( MarkdownParseError(..) + , markdownToHtml + ) where + +import Data.Text (Text) +import Lucid +import Path (File, Path, Rel) +import Text.Megaparsec (ParseErrorBundle (..)) +import Text.MMark (MMarkErr) + +import qualified Path +import qualified Text.MMark as MMark + +-- | Wrapper around `MMarkErr` errors +newtype MarkdownParseError = MarkdownParseError + { unwrap :: ParseErrorBundle Text MMarkErr + } + +{-| Takes a text that could contain markdown and returns the generated HTML. + If an error occurs while parsing, it also returns the error information. +-} +markdownToHtml + :: Path Rel File -- ^ Used by `Mmark.parse` for error messages + -> Text -- ^ Text to parse + -> Either MarkdownParseError (Html ()) +markdownToHtml relFile contents = + case MMark.parse (Path.fromRelFile relFile) contents of + Left err -> Left MarkdownParseError { unwrap = err } + Right mmark -> Right $ MMark.render mmark diff --git a/src/Dhall/Docs/Store.hs b/src/Dhall/Docs/Store.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Docs/Store.hs @@ -0,0 +1,48 @@ +{-| Utilities to interact with the dhall-docs home directory +-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# LANGUAGE QuasiQuotes #-} + + +module Dhall.Docs.Store (getDocsHomeDirectory, makeHashForDirectory) where + +import Dhall.Crypto (SHA256Digest (..), sha256Hash) +import Path (Abs, Dir, Path, Rel) +import Path.IO (XdgDirectory (..)) + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar.Entry +import qualified Data.ByteString.Lazy +import qualified Data.List +import qualified Path +import qualified Path.IO + +{-| Fetches the dhall-docs home directory. If @XDG_DATA_HOME@ env var is + defined, then @${XDG_DATA_HOME}/dhall-docs@ will be returned. Otherwise, + "${HOME}/.local/share/dhall-docs" +-} +getDocsHomeDirectory :: IO (Path Abs Dir) +getDocsHomeDirectory = do + dir <- Path.IO.getXdgDir Path.IO.XdgData $ Just $ [Path.reldir|dhall-docs|] + Path.IO.ensureDir dir + return dir + +{-| Compute the hash for a directory. It takes into account the hierarchy + structure of it and the contents of its files, but not the name of the + actual files. + + This is done by computing the hash of each file and sorting them by its + absolute file name, and computing the hash of the concatenation of all + hashes. +-} +makeHashForDirectory :: Path Abs Dir -> IO SHA256Digest +makeHashForDirectory dir = do + -- Builds a map so key order is preserved between several calls + files <- Data.List.sort . map Path.fromRelFile . snd + <$> Path.IO.listDirRecurRel dir + + let setTimeToZero entry = entry{Tar.Entry.entryTime = 0} + inMemoryTarBytes <- Data.ByteString.Lazy.toStrict . Tar.write . map setTimeToZero + <$> Tar.pack (Path.fromAbsDir dir) files + + return $ sha256Hash inMemoryTarBytes diff --git a/src/Dhall/data/dhall-icon.svg b/src/Dhall/data/dhall-icon.svg new file mode 100644 --- /dev/null +++ b/src/Dhall/data/dhall-icon.svg @@ -0,0 +1,1 @@ + diff --git a/src/Dhall/data/index.css b/src/Dhall/data/index.css new file mode 100644 --- /dev/null +++ b/src/Dhall/data/index.css @@ -0,0 +1,244 @@ +/* + primary-color: #C4C4C4 + secondary-color: #EBEBEB + accent-color1: #FFA632 + accent-color2: #008489 + accent-color3: #914669 +*/ + +/******** Common rules ********/ + +body { + padding: 0; + margin: 0; + background-color: #EBEBEB; + transition: 0.5s; +} + +body * { + font-family: 'Lato', sans-serif; +} + +a { + transition: 0.5s; + color: #008489; +} + +a:visited { + color: #914669; +} + +a:active { + color: #FFA632; +} + +/******** Markdown specific code ********/ + +code { + font-family: 'Fira Code', monospace; +} + +blockquote { + border-left: 9px solid #aaa; + background-color: #bdbdbd; + padding: 0.2rem; + color: #616161; +} + +/******** Nav bar **********/ + +.nav-bar { + display: flex; + align-items: center; + padding: 0.3rem; + background-color: #484848; + color: #EBEBEB; + transition: 0.5s; +} + +.nav-bar .dhall-icon { + max-width: 2.5rem; + margin: 0.5rem; +} + +.nav-bar .package-title { + font-size: 1.3rem; + margin: 0; + margin-left: 1rem; +} + +.nav-bar a.nav-option { + font-size: 1rem; + height: 100%; + margin: 0 0.5rem; + cursor: pointer; + transition: 0.5s; + text-decoration: none; +} + +.nav-bar a.nav-option:hover { + text-decoration: underline; + text-decoration-color: #EBEBEB; +} + +.nav-bar a.nav-option:active, .nav-bar a.nav-option, .nav-bar a.nav-option:visited { + color: #EBEBEB; +} + +.nav-bar .nav-bar-content-divider { + flex: 1; +} + +/******** Main content **********/ + +.main-container { + padding: 2rem; + padding-top: 0; + transition: 0.5s; +} + +h2.doc-title span, h2.doc-title a { + font-family: 'Fira Code', monospace; +} + +span.crumb-divider:first-child { + margin-left: 0; +} + +span.crumb-divider { + margin: 0 0.5rem; +} + +a.title-crumb { + text-decoration: none; +} + +a.title-crumb:hover { + text-decoration: underline; +} + +a.copy-to-clipboard { + margin-top: 0; + color: #888 !important; + user-select: none; + cursor: pointer; + text-decoration: none; +} + +a.copy-to-clipboard:hover { + text-decoration: underline; +} + +h2.doc-title { + margin-bottom: 0; +} + +/******** Source code **********/ + + +.code-examples > pre { + padding-top: 0 !important; + padding-bottom: 0 !important; +} + +.source-code { + padding: 0rem; +} + +.source-code pre { + padding: 1rem; + font-family: 'Fira Code', monospace; + color: #333333; +} + +.source-code span { + font-family: 'Fira Code', monospace; + color: #333333; +} + +.source-code span.dhall-keyword { + color: #0000FF; + font-weight: bold; +} + +.source-code span.dhall-syntax { + color: #AF00DB; +} + +.source-code span.dhall-literal { + color: #098658; + font-weight: bold; +} + +.source-code span.dhall-builtin { + color: #267F99; + font-weight: bold; +} + +.dhall-type { + font-family: 'Fira Code', monospace; +} + +.dhall-type pre { + display: inline; + padding: 0; +} + +span.of-type-token { + margin-left: 0.5rem; + margin-right: 0.5rem; +} + +/******** Dark mode styling ********/ + +.dark-mode .main-container { + color: #EBEBEB; +} + +body.dark-mode { + background-color: #484848; +} + +.dark-mode .nav-bar { + background-color: #5d5d5d; +} + +.dark-mode a { + color: #FFA632; +} + +.dark-mode a:visited { + color: #008489; +} + +.dark-mode a:active { + color: #914669; +} + +.dark-mode .source-code pre { + color: #D4D4D4; +} + +.dark-mode .source-code span { + color: #D4D4D4; +} + +.dark-mode .source-code span.dhall-keyword { + color: #569CD6; +} + +.dark-mode .source-code span.dhall-syntax { + color: #C586C0; +} + +.dark-mode .source-code span.dhall-literal { + color: #B5CEA8; +} + +.dark-mode .source-code span.dhall-builtin { + color: #4EC9B0; +} + +.dark-mode a.copy-to-clipboard { + color: #bdbdbd !important; +} diff --git a/src/Dhall/data/index.js b/src/Dhall/data/index.js new file mode 100644 --- /dev/null +++ b/src/Dhall/data/index.js @@ -0,0 +1,36 @@ +const DARK_MODE_OPT = 'dark-mode' +const DARK_MODE_ACTIVE = 'dark-mode-active' +const DARK_MODE_INACTIVE = 'dark-mode-inactive' + +function onReady() { + if (localStorage.getItem(DARK_MODE_OPT) == DARK_MODE_ACTIVE) { + document.body.classList.add('dark-mode') + } else { + document.body.classList.remove('dark-mode') + } + document.getElementById('switch-light-dark-mode') + .addEventListener('click', () => { + document.body.classList.toggle('dark-mode') + if (document.body.classList.contains('dark-mode')) { + localStorage.setItem(DARK_MODE_OPT, DARK_MODE_ACTIVE) + } else { + localStorage.setItem(DARK_MODE_OPT, DARK_MODE_INACTIVE) + } + }) + + document.querySelectorAll('a.copy-to-clipboard').forEach(node => + node.addEventListener('click', () => { + const temp = document.createElement('input') + document.body.append(temp) + temp.value = node.dataset.path + temp.select() + document.execCommand("copy"); + temp.remove() + })) +} + +if (document.readyState != 'loading'){ + onReady(); +} else { + document.addEventListener('DOMContentLoaded', onReady); +} diff --git a/tasty/Main.hs b/tasty/Main.hs new file mode 100644 --- /dev/null +++ b/tasty/Main.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + +module Main (main) where + +import Data.Map.Strict (Map) +import Data.Text (Text) +import Dhall.Docs.Core +import Path (Dir, File, Path, Rel, ()) +import Test.Tasty (TestTree) + +import qualified Control.Monad +import qualified Data.Map.Strict as Map +import qualified Data.Text +import qualified Data.Text.IO as Text.IO +import qualified GHC.IO.Encoding +import qualified Path +import qualified Path.IO +import qualified Test.Tasty +import qualified Test.Tasty.Silver as Silver +import qualified Test.Tasty.Silver.Interactive as Silver +import qualified Text.PrettyPrint as Pretty +import qualified Text.XML.HaXml.Html.Parse as HaXml +import qualified Text.XML.HaXml.Pretty as HaXml + +main :: IO () +main = do + GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8 + + input <- getPackageContents + let GeneratedDocs _ docs = generateDocsPure "test-package" input + let docsMap = Map.fromList docs + Silver.defaultMain $ testTree docsMap + +getDirContents :: Path Rel Dir -> IO [(Path Rel File, Text)] +getDirContents dataDir = do + files <- snd <$> Path.IO.listDirRecurRel dataDir + Control.Monad.forM files $ \file -> do + contents <- Text.IO.readFile $ Path.fromRelFile $ dataDir file + return (file, contents) + +goldenDir :: Path Rel Dir +goldenDir = $(Path.mkRelDir "./tasty/data/golden") + +getPackageContents :: IO [(Path Rel File, Text)] +getPackageContents = getDirContents $(Path.mkRelDir "./tasty/data/package") + +testTree :: Map (Path Rel File) Text -> TestTree +testTree docsMap = + Test.Tasty.testGroup "dhall-docs" + $ map makeTest $ Map.assocs docsMap + where + makeTest :: (Path Rel File, Text) -> TestTree + makeTest (testFile, text) = + Silver.goldenVsAction testName goldenFilePath action converter + where + goldenFilePath = Path.fromRelFile $ goldenDir testFile + testName = Path.fromRelFile testFile + action = return prettyHtmlDoc + converter = Data.Text.pack + + prettyHtmlDoc = Pretty.render + $ HaXml.document + $ HaXml.htmlParse testName (Data.Text.unpack text) diff --git a/tasty/data/golden/IndexesExample.dhall.html b/tasty/data/golden/IndexesExample.dhall.html new file mode 100644 --- /dev/null +++ b/tasty/data/golden/IndexesExample.dhall.html @@ -0,0 +1,77 @@ + +/IndexesExample.dhall