HaddockGenerator.hs

module Parochial.HaddockGenerator (
    createSymLinkFarm
  , installedHaddocks
  , installedHaddocks'
  ) where


import           Protolude hiding (packageName)

import qualified Data.List as L

import           Distribution.Types.Version
import           Distribution.Types.PackageId
import           Distribution.Types.PackageName
import           Distribution.Types.LocalBuildInfo

import           Distribution.Simple.PackageIndex
import           Distribution.InstalledPackageInfo

import           System.FilePath
import           System.Directory
import           System.PosixCompat.Files

import           Text.Blaze.Html.Renderer.Pretty ( renderHtml )

import           Text.Blaze.Html5 ((!))
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A

import           Parochial.Types


-- | Predefined list of blacklisted packages. This is dirty nasty hack because Hoogle
--   dies when it parses certain files it shouldn't, ironically it dies parsing it's
--   own package! See https://github.com/ndmitchell/hoogle/issues/362 for more details.
--
--   The downside of this approach is that it won't build the documentation for these
--   packages
blackListedPagkages :: [Text]
blackListedPagkages = ["hoogle"]


-- | Construct a project specific symlink farm which links the installed haddocks to the
--   project and wraps it in a (very) primitive html page.
createSymLinkFarm :: Target -> [Pkg] -> IO ()
createSymLinkFarm t i = removeSymLinks t >> (generateSymLinks t i >>= createIndex t)


-- | Builds a symlink farm from the package database so that when the documentation is served
--   up by a web server the links are correct.
generateSymLinks :: Target -> [Pkg] -> IO [Pkg]
generateSymLinks target = traverse generateSymLink
  where
    generateSymLink (pId, p) = createSymbolicLink p (path pId) >> pure (pId, p)
    path = (target </>) . toS . packageName


-- | Remove all symlinks to ensure there are no dangling links or links pointing to the wrong
--   versions.
removeSymLinks :: Target -> IO ()
removeSymLinks path = listDirectoryAbs >>= filterM pathIsSymbolicLink >>= traverse_ removeFile
  where
    listDirectoryAbs = listDirectory path >>= traverse (pure . (path </>))


-- | Contrive a @Pkg@ for the locally installed documentation
projectPkg :: LocalBuildInfo -> Pkg
projectPkg lbi = (projectIdentifier lbi, takeDirectory (buildDir lbi) </> "doc" </> "html" </> name </> name)
  where
    name = toS $ packageName (projectIdentifier lbi)


-- | Extract the @PackageIdentifier@ for the project.
projectIdentifier :: LocalBuildInfo -> PackageIdentifier
projectIdentifier = localPackage


-- | Find all project dependencies and filter out any promlematic ones. This isn't
--   particularly efficeient but given it's performing IO it won't make much difference.
installedHaddocks :: LocalBuildInfo -> IO [Pkg]
installedHaddocks = filterM hasIndexHtml . extract . filterPackages . allPackages . installedPkgs
  where
    -- FIXME mconcat not correct and needs to be done properly. I'm not sure what properly is though!
    extract :: [InstalledPackageInfo] -> [Pkg]
    extract = map (\i -> (sourcePackageId i, mconcat $ haddockHTMLs i))

    filterPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
    filterPackages = L.filter (liftM2 (&&) isBlacklisted isNotEmpty)

    isBlacklisted :: InstalledPackageInfo -> Bool
    isBlacklisted = not . flip elem blackListedPagkages . packageName . sourcePackageId

    isNotEmpty :: InstalledPackageInfo -> Bool
    isNotEmpty = not . null . haddockHTMLs

    hasIndexHtml :: Pkg -> IO Bool
    hasIndexHtml = fileExist . indexPath . snd


-- | The same as @installedHaddocks@ but included the project documentation.
installedHaddocks' :: LocalBuildInfo -> IO [Pkg]
installedHaddocks' i = installedHaddocks i >>= \h -> return (projectPkg i : h)


-------------------------------------------------------
-- HTML
-------------------------------------------------------

-- | Write the project specific index.html file.
createIndex :: Target -> [Pkg] -> IO ()
createIndex t ps = withFile (indexPath t) WriteMode write
  where
    write = flip hPutStr (renderHtml generateHtml)

    generateHtml = H.docTypeHtml $ do
      H.head $ H.title (H.text $ toS t)
      H.body $ H.ul $ forM_ ps (H.li . pkgLink)

    pkgLink :: Pkg -> H.Html
    pkgLink (pId, _) = H.a ! A.href (H.toValue (indexPath (toS $ packageName pId))) $
                               H.text (libName pId)


indexPath :: FilePath -> FilePath
indexPath = (</> "index.html")


-------------------------------------------------------
-- Utilities
-------------------------------------------------------

libName :: PackageIdentifier -> Text
libName p = packageName p <> " — " <> fmtVersion p
  where
    fmtVersion = toS . L.intercalate "." . map show . versionNumbers . pkgVersion


packageName :: PackageIdentifier -> Text
packageName = toS . unPackageName . pkgName