mkhoogle.hs

{-# LANGUAGE TupleSections #-}

module Main (main) where

-- | Build a default.hoo database for fully local use.
--
-- It uses the .txt hoogle database generated by haddock. In order to build them
-- with cabal, you have to enable in .cabal
--
-- documentation: True
-- haddock
--   hoogle: True
--   html: True
--
-- To generate the database, go to
-- /home/<user>/.cabal/share/<arch-ghc>/hoogle-<version>/databases
-- and run the script : runhaskell ./mkhoogle.hs.
-- It can take few minutes, and after a bunch of parse errors,
-- the file 'default.hoo' will be created (or overwritten)
--
-- The errors are harmless. Hoogle complains with parse errors, even with some
-- hacks (see hacks function) on the .txt files from Haddock,
--
-- To browse the docs with hoogle, run :
-- hoogle server --local -p 8080
-- and go to http://localhost:8080

import Control.Applicative ((<$>))
import Control.Monad       (filterM, when)

import Data.Char  (isAlpha)
import Data.List  (isPrefixOf, sortBy)
import Data.Maybe (isNothing, listToMaybe)
import Data.Ord   (comparing)

import System.Directory (doesFileExist)
import System.FilePath  (addExtension, (</>))

import Distribution.InstalledPackageInfo (InstalledPackageInfo,
                                          InstalledPackageInfo_ (..))
import Distribution.Package              (PackageIdentifier (..),
                                          PackageName (..))
import Distribution.Simple.Compiler      (PackageDB (..))
import Distribution.Simple.GHC           (getInstalledPackages)
import Distribution.Simple.PackageIndex  (allPackagesByName)
import Distribution.Simple.Program       (addKnownPrograms,
                                          configureAllKnownPrograms,
                                          emptyProgramConfiguration,
                                          ghcPkgProgram, ghcProgram)
import Distribution.Verbosity            (normal)

import Hoogle (Language (Haskell), createDatabase)


main :: IO ()
main = do
    putStrLn "Loading ghc-pkg database..."

    config <- configureAllKnownPrograms normal
            . addKnownPrograms [ghcProgram, ghcPkgProgram]
            $ emptyProgramConfiguration

    pkgs <- allPackagesByName
            <$> getInstalledPackages normal
                                     [GlobalPackageDB, UserPackageDB]
                                     config

    let nPkg = length pkgs
    putStrLn $  "Searching Haddock dirs and Hoogle databases for "
             ++ show (length pkgs) ++ " packages..."

    txts <- mapM getPkgHoo pkgs

    let txtsFound = filter (/= []) txts
        nFound = length txtsFound
        nNotFounds = nPkg - nFound
        str = unlines . concat $ txtsFound

    putStrLn $ show nNotFounds ++ " packages don't have a Hoogle database."
    putStrLn $ "Found " ++ show nFound ++ " .txt databases. Processing them..."

    errs <- createDatabase "http://hackage.haskell.org/" Haskell []
            str "default.hoo"

    putStr . unlines . map show $ errs

    putStrLn "Done!"


getPkgHoo :: (PackageName, [InstalledPackageInfo]) -> IO [String]
getPkgHoo (PackageName name, ipInfos) = do
    let ipInfosByV = sortBy (flip $ comparing
                            $ pkgVersion . sourcePackageId
                            ) ipInfos
        hadDirs = concatMap haddockHTMLs ipInfosByV
    hooFileM <- firstFound . map (</> name `addExtension` "txt") $ hadDirs
    hadFileM <- firstFound . map (</> "index.html")              $ hadDirs

    when (isNothing hadFileM) . putStrLn $ "No Haddock documentation for package "
                                         ++ show name

    maybe ( putStrLn ("Database not found for package " ++ show name)
            >> return []
          )
          ( fmap (maybe id addDoc hadFileM . hacks . lines)
          . readFile
          )
          hooFileM
  where
    firstFound  = fmap listToMaybe . filterM doesFileExist
    addDoc hadFile = foldr f []
      where
        f x xs | "@package " `isPrefixOf` x = ("@url file://" ++ hadFile):x:xs
               | otherwise = x:xs

-- | rewrite some statements in haddock generated files (from Hoogle code)
hacks :: [String] -> [String]
hacks =
    map (unwords . g . map f . words)
  . filter (not . isPrefixOf "@version ")
  where
    f "::" = "::"
    f (':':xs) = "(:" ++ xs ++ ")"
    f ('!':'!':x:xs) | isAlpha x = xs
    f ('!':x:xs) | isAlpha x || x `elem` "[(" = x:xs
    f x | x `elem` ["[overlap","ok]","[incoherent]","[safe]"] = ""
    f x | x `elem` ["{-#","UNPACK","#-}"] = ""
    f x = x

    g ("where":_) = []
    g (x:xs) = x : g xs
    g [] = []