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 :: [Text]
blackListedPagkages = [Text
"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 :: Target -> [Pkg] -> IO ()
createSymLinkFarm Target
t [Pkg]
i = Target -> IO ()
removeSymLinks Target
t IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Target -> [Pkg] -> IO [Pkg]
generateSymLinks Target
t [Pkg]
i IO [Pkg] -> ([Pkg] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Target -> [Pkg] -> IO ()
createIndex Target
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 -> [Pkg] -> IO [Pkg]
generateSymLinks Target
target = (Pkg -> IO Pkg) -> [Pkg] -> IO [Pkg]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Pkg -> IO Pkg
generateSymLink
  where
    generateSymLink :: Pkg -> IO Pkg
generateSymLink (PackageIdentifier
pId, Target
p) = Target -> Target -> IO ()
createSymbolicLink Target
p (PackageIdentifier -> Target
path PackageIdentifier
pId) IO () -> IO Pkg -> IO Pkg
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pkg -> IO Pkg
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifier
pId, Target
p)
    path :: PackageIdentifier -> Target
path = (Target
target Target -> Target -> Target
</>) (Target -> Target)
-> (PackageIdentifier -> Target) -> PackageIdentifier -> Target
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Target
forall a b. ConvertText a b => a -> b
toS (Text -> Target)
-> (PackageIdentifier -> Text) -> PackageIdentifier -> Target
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> Text
packageName


-- | Remove all symlinks to ensure there are no dangling links or links pointing to the wrong
--   versions.
removeSymLinks :: Target -> IO ()
removeSymLinks :: Target -> IO ()
removeSymLinks Target
path = IO [Target]
listDirectoryAbs IO [Target] -> ([Target] -> IO [Target]) -> IO [Target]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Target -> IO Bool) -> [Target] -> IO [Target]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Target -> IO Bool
pathIsSymbolicLink IO [Target] -> ([Target] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Target -> IO ()) -> [Target] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Target -> IO ()
removeFile
  where
    listDirectoryAbs :: IO [Target]
listDirectoryAbs = Target -> IO [Target]
listDirectory Target
path IO [Target] -> ([Target] -> IO [Target]) -> IO [Target]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Target -> IO Target) -> [Target] -> IO [Target]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Target -> IO Target
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Target -> IO Target) -> (Target -> Target) -> Target -> IO Target
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Target
path Target -> Target -> Target
</>))


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


-- | Extract the @PackageIdentifier@ for the project.
projectIdentifier :: LocalBuildInfo -> PackageIdentifier
projectIdentifier :: LocalBuildInfo -> PackageIdentifier
projectIdentifier = LocalBuildInfo -> PackageIdentifier
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 :: LocalBuildInfo -> IO [Pkg]
installedHaddocks = (Pkg -> IO Bool) -> [Pkg] -> IO [Pkg]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Pkg -> IO Bool
hasIndexHtml ([Pkg] -> IO [Pkg])
-> (LocalBuildInfo -> [Pkg]) -> LocalBuildInfo -> IO [Pkg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InstalledPackageInfo] -> [Pkg]
extract ([InstalledPackageInfo] -> [Pkg])
-> (LocalBuildInfo -> [InstalledPackageInfo])
-> LocalBuildInfo
-> [Pkg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InstalledPackageInfo] -> [InstalledPackageInfo]
filterPackages ([InstalledPackageInfo] -> [InstalledPackageInfo])
-> (LocalBuildInfo -> [InstalledPackageInfo])
-> LocalBuildInfo
-> [InstalledPackageInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIndex InstalledPackageInfo -> [InstalledPackageInfo]
forall a. PackageIndex a -> [a]
allPackages (PackageIndex InstalledPackageInfo -> [InstalledPackageInfo])
-> (LocalBuildInfo -> PackageIndex InstalledPackageInfo)
-> LocalBuildInfo
-> [InstalledPackageInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalBuildInfo -> PackageIndex InstalledPackageInfo
installedPkgs
  where
    -- FIXME mconcat not correct and needs to be done properly. I'm not sure what properly is though!
    extract :: [InstalledPackageInfo] -> [Pkg]
    extract :: [InstalledPackageInfo] -> [Pkg]
extract = (InstalledPackageInfo -> Pkg) -> [InstalledPackageInfo] -> [Pkg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\InstalledPackageInfo
i -> (InstalledPackageInfo -> PackageIdentifier
sourcePackageId InstalledPackageInfo
i, [Target] -> Target
forall a. Monoid a => [a] -> a
mconcat ([Target] -> Target) -> [Target] -> Target
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo -> [Target]
haddockHTMLs InstalledPackageInfo
i))

    filterPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
    filterPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
filterPackages = (InstalledPackageInfo -> Bool)
-> [InstalledPackageInfo] -> [InstalledPackageInfo]
forall a. (a -> Bool) -> [a] -> [a]
L.filter ((Bool -> Bool -> Bool)
-> (InstalledPackageInfo -> Bool)
-> (InstalledPackageInfo -> Bool)
-> InstalledPackageInfo
-> Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) InstalledPackageInfo -> Bool
isBlacklisted InstalledPackageInfo -> Bool
isNotEmpty)

    isBlacklisted :: InstalledPackageInfo -> Bool
    isBlacklisted :: InstalledPackageInfo -> Bool
isBlacklisted = Bool -> Bool
not (Bool -> Bool)
-> (InstalledPackageInfo -> Bool) -> InstalledPackageInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> [Text] -> Bool) -> [Text] -> Text -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Text]
blackListedPagkages (Text -> Bool)
-> (InstalledPackageInfo -> Text) -> InstalledPackageInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> Text
packageName (PackageIdentifier -> Text)
-> (InstalledPackageInfo -> PackageIdentifier)
-> InstalledPackageInfo
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> PackageIdentifier
sourcePackageId

    isNotEmpty :: InstalledPackageInfo -> Bool
    isNotEmpty :: InstalledPackageInfo -> Bool
isNotEmpty = Bool -> Bool
not (Bool -> Bool)
-> (InstalledPackageInfo -> Bool) -> InstalledPackageInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Target] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Target] -> Bool)
-> (InstalledPackageInfo -> [Target])
-> InstalledPackageInfo
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> [Target]
haddockHTMLs

    hasIndexHtml :: Pkg -> IO Bool
    hasIndexHtml :: Pkg -> IO Bool
hasIndexHtml = Target -> IO Bool
fileExist (Target -> IO Bool) -> (Pkg -> Target) -> Pkg -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Target -> Target
indexPath (Target -> Target) -> (Pkg -> Target) -> Pkg -> Target
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pkg -> Target
forall a b. (a, b) -> b
snd


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


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

-- | Write the project specific index.html file.
createIndex :: Target -> [Pkg] -> IO ()
createIndex :: Target -> [Pkg] -> IO ()
createIndex Target
t [Pkg]
ps = Target -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. Target -> IOMode -> (Handle -> IO r) -> IO r
withFile (Target -> Target
indexPath Target
t) IOMode
WriteMode Handle -> IO ()
write
  where
    write :: Handle -> IO ()
write = (Handle -> Target -> IO ()) -> Target -> Handle -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> Target -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => Handle -> a -> m ()
hPutStr (Html -> Target
renderHtml Html
generateHtml)

    generateHtml :: Html
generateHtml = Html -> Html
H.docTypeHtml (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.head (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.title (Text -> Html
H.text (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ Target -> Text
forall a b. ConvertText a b => a -> b
toS Target
t)
      Html -> Html
H.body (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.ul (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Pkg] -> (Pkg -> Html) -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Pkg]
ps (Html -> Html
H.li (Html -> Html) -> (Pkg -> Html) -> Pkg -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pkg -> Html
pkgLink)

    pkgLink :: Pkg -> H.Html
    pkgLink :: Pkg -> Html
pkgLink (PackageIdentifier
pId, Target
_) = Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (Target -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (Target -> Target
indexPath (Text -> Target
forall a b. ConvertText a b => a -> b
toS (Text -> Target) -> Text -> Target
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Text
packageName PackageIdentifier
pId))) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
                               Text -> Html
H.text (PackageIdentifier -> Text
libName PackageIdentifier
pId)


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


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

libName :: PackageIdentifier -> Text
libName :: PackageIdentifier -> Text
libName PackageIdentifier
p = PackageIdentifier -> Text
packageName PackageIdentifier
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" — " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PackageIdentifier -> Text
fmtVersion PackageIdentifier
p
  where
    fmtVersion :: PackageIdentifier -> Text
fmtVersion = Target -> Text
forall a b. ConvertText a b => a -> b
toS (Target -> Text)
-> (PackageIdentifier -> Target) -> PackageIdentifier -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Target -> [Target] -> Target
forall a. [a] -> [[a]] -> [a]
L.intercalate Target
"." ([Target] -> Target)
-> (PackageIdentifier -> [Target]) -> PackageIdentifier -> Target
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Target) -> [Int] -> [Target]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Int -> Target
forall a b. (Show a, ConvertText Target b) => a -> b
show ([Int] -> [Target])
-> (PackageIdentifier -> [Int]) -> PackageIdentifier -> [Target]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> [Int]
versionNumbers (Version -> [Int])
-> (PackageIdentifier -> Version) -> PackageIdentifier -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> Version
pkgVersion


packageName :: PackageIdentifier -> Text
packageName :: PackageIdentifier -> Text
packageName = Target -> Text
forall a b. ConvertText a b => a -> b
toS (Target -> Text)
-> (PackageIdentifier -> Target) -> PackageIdentifier -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> Target
unPackageName (PackageName -> Target)
-> (PackageIdentifier -> PackageName)
-> PackageIdentifier
-> Target
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName