Core.hs

{-| 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 FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE ViewPatterns          #-}
-- {-# OPTIONS_GHC -Wno-unused-imports #-}

module Dhall.Docs.Core
    ( -- * Core functionality
      generateDocs
    , generateDocsPure
    , GeneratedDocs(..)

      -- * Comment parsing
    , 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.Docs.Util            (fileAnIssue)
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

-- $setup
-- >>> :set -XQuasiQuotes
-- >>> import Path (reldir)

-- | The result of the doc-generator pure component
data GeneratedDocs a = GeneratedDocs [DocsGenWarning] a
    deriving (Show)

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)
    | InvalidMarkdownHeader MarkdownParseError
    | InvalidMarkdownFile 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 (InvalidMarkdownHeader 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 (InvalidMarkdownFile MarkdownParseError{..}) =
        warn <>"Failed to parse file as markdown\n\n" <>
        Text.Megaparsec.errorBundlePretty unwrap <>
        "The original file contents 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:\n" <>
                "* For the first line: \"--| \"\n" <>
                "* For the rest of the lines: \"--  \""

-- | Extracted text from from Dhall file's comments
newtype FileComments = FileComments
    { headerComment :: Maybe DhallDocsText -- ^ 'Nothing' if no comment or if invalid
    } deriving (Show)

-- | 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 RenderedFile = RenderedFile
    { path :: Path Rel File
      -- ^ Path of the file
    , contents :: Text
      -- ^ File contents
    , fileType :: FileType
      -- ^ This corresponds to the import mode (e.g. @as Text@)
    } deriving (Show)

data FileType
    = DhallFile
        { expr :: Expr Src Import
          -- ^ Parsed AST from 'contents'
        , 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
        , fileComments :: FileComments
        }
    | MarkdownFile
        { mmark :: MMark
          -- ^ Parsed Markdown from 'contents'
        }
    | TextFile
    deriving (Show)

data FileExtension = DhallExtension | MarkdownExtension | OtherExtension deriving (Show)

{-| Takes a list of files paths with their contents and returns the list of
    valid `RenderedFile`s.

    Returned files contains all the information to be used on `Html ()`
    generation.

    The result is sorted by `path`
-}
getAllRenderedFiles :: [(Path Rel File, ByteString)] -> GeneratedDocs [RenderedFile]
getAllRenderedFiles =
    fmap Maybe.catMaybes . mapM toRenderedFile . foldr validFiles []
  where
    getFileExtension :: Path Rel File -> FileExtension
    getFileExtension absFile =
        case snd <$> Path.splitExtension absFile of
            Just ".dhall" -> DhallExtension
            Just ".md" -> MarkdownExtension
            _ -> OtherExtension

    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

    toRenderedFile
        :: (Path Rel File, Text) -> GeneratedDocs (Maybe RenderedFile)
    toRenderedFile (relFile, contents) =
        case (exprAndHeaderFromText (Path.fromRelFile relFile) contents, getFileExtension relFile) 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 $ RenderedFile
                    { contents
                    , path = relFile
                    , fileType = DhallFile
                        { expr
                        , mType = extractTypeIfInSource denoted
                        , examples = examplesFromAssertions denoted
                        , fileComments = FileComments headerContents
                        }
                    }
            (Left ParseError{..}, DhallExtension) -> do
                Writer.tell [InvalidDhall unwrap]
                return Nothing

            (Left ParseError{}, MarkdownExtension) ->
                case parseMarkdown relFile contents of
                    Right mmark ->
                        return $ Just $ RenderedFile
                            { contents
                            , path = relFile
                            , fileType = MarkdownFile mmark
                            }
                    Left err -> do
                        Writer.tell [InvalidMarkdownFile err]
                        return $ Just $ RenderedFile
                            { contents
                            , path = relFile
                            , fileType = TextFile
                            }

            _ -> do
                return $ Just $ RenderedFile
                    { contents
                    , path = relFile
                    , fileType = TextFile
                    }

    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

        -- | 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 let 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 `RenderedFile`
makeHtml
    :: Maybe Text           -- ^ Base import URL
    -> Text                 -- ^ Package name
    -> CharacterSet         -- ^ Output encoding
    -> RenderedFile            -- ^ Parsed header
    -> GeneratedDocs Text
makeHtml baseImportUrl packageName characterSet RenderedFile{..} = do
    let relativeResourcesPath = resolveRelativePath (Path.parent path)

    case fileType of
        DhallFile{..} -> do
            let strippedHeader =
                    Maybe.maybe "" unDhallDocsText (headerComment fileComments)

            headerAsHtml <-
                case markdownToHtml path strippedHeader of
                    Left err -> do
                        Writer.tell [InvalidMarkdownHeader 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, baseImportUrl }

            return htmlAsText

        MarkdownFile mmark -> do
            let htmlAsText =
                    Text.Lazy.toStrict $ Lucid.renderText $ markdownFileToHtml
                        path
                        contents
                        (render mmark)
                        DocParams{ relativeResourcesPath, packageName, characterSet, baseImportUrl }
            return htmlAsText

        TextFile -> do
            let htmlAsText =
                    Text.Lazy.toStrict $ Lucid.renderText $ textFileToHtml
                        path
                        contents
                        DocParams{ relativeResourcesPath, packageName, characterSet, baseImportUrl }

            return htmlAsText


{-| 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
    :: Maybe Text
    -> Text
    -> CharacterSet
    -> [RenderedFile]
    -> [(Path Rel File, Text)]
createIndexes baseImportUrl packageName characterSet renderedFiles = map toIndex dirToDirsAndFilesMapAssocs
  where
    -- Files grouped by their directory
    dirToFilesMap :: Map (Path Rel Dir) [RenderedFile]
    dirToFilesMap = Map.unionsWith (<>) $ map toMap $ Data.List.sortBy (compare `on` path) renderedFiles
      where
        toMap :: RenderedFile -> Map (Path Rel Dir) [RenderedFile]
        toMap renderedFile = Map.singleton (Path.parent $ path renderedFile) [renderedFile]

    {-  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 = foldr cons Map.empty dirs
      where
        dirs = filter keep (Map.keys dirToFilesMap)
          where
            keep reldir = Path.parent reldir /= reldir

        cons d = Map.insertWith (<>) (Path.parent d) [d]

    dirToDirsAndFilesMapAssocs :: [(Path Rel Dir, ([RenderedFile], [Path Rel Dir]))]
    dirToDirsAndFilesMapAssocs = Map.assocs $
        Map.Merge.merge
            (Map.Merge.mapMissing onlyFiles)
            (Map.Merge.mapMissing onlyDirectories)
            (Map.Merge.zipWithMatched both)
            dirToFilesMap
            dirToDirsMap
      where
        onlyFiles       _ files             = (files, []         )
        onlyDirectories _       directories = ([]   , directories)
        both            _ files directories = (files, directories)

    toIndex :: (Path Rel Dir, ([RenderedFile], [Path Rel Dir])) -> (Path Rel File, Text)
    toIndex (indexDir, (files, dirs)) =
        (indexDir </> $(Path.mkRelFile "index.html"), Text.Lazy.toStrict $ Lucid.renderText html)
      where
        adapt RenderedFile{..} = (stripPrefix (addHtmlExt path), m)
          where
            m = case fileType of
                DhallFile{..}  -> mType
                MarkdownFile _ -> Nothing
                TextFile       -> Nothing

        html = indexToHtml
            indexDir
            (map adapt files)
            (map stripPrefix dirs)
            DocParams { relativeResourcesPath = resolveRelativePath indexDir, packageName, characterSet, baseImportUrl }

        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

{-| 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
    -> Maybe Text   -- ^ Base import URL
    -> Text         -- ^ Package name, used in some HTML titles
    -> CharacterSet -- ^ Output encoding
    -> IO ()
generateDocs inputDir outLink baseImportUrl 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 baseImportUrl 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

{-| 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
    :: Maybe Text              -- ^ Base import URL
    -> Text                    -- ^ Package name
    -> CharacterSet            -- ^ Output encoding
    -> [(Path Rel File, ByteString)] -- ^ (Input file, contents)
    -> GeneratedDocs [(Path Rel File, Text)]
generateDocsPure baseImportUrl packageName characterSet inputFiles = go
  where
    go :: GeneratedDocs [(Path Rel File, Text)]
    go = do
        renderedFiles <- getAllRenderedFiles inputFiles
        htmls <- mapM (makeHtml baseImportUrl packageName characterSet) renderedFiles
        let indexes = createIndexes baseImportUrl packageName characterSet renderedFiles
        return (zip (map (addHtmlExt . path) renderedFiles) htmls <> indexes)