Ticket #157: haddock-index.hs

{-
 - Read .haddock files, pkg database, build documentation index;
 - for each documented ID, output list of modules it appears in,
 -  with the URLs into the Haddock HTML pages
 -
 - Dependencies: haddock, cabal, ghc, ghc-paths, ..
 -
 - Usage:
 -  haddock-index [--installed] [--withDocs] {[x/html,]x.haddock}*
 -
 - Options: 
 -  --installed (process all installed .haddock files)
 -  --withDocs  (add documentation from .haddock files)
 -
 - this is similar to haddock's --gen-index, as invoked from cabal,
 - but we need control over the output format (with a little more
 - tinkering, Vim will be able to read this in as one of its nested
 - maps/hashtables, so haskellmode can use it for documentation lookup,
 - identifier completion, and so on; other IDEs will need slightly
 - different formats; most users will still want the HTML index in
 - addition to what the IDEs are using), so the haddock library should 
 - just expose the index in Haskell, for further processing;
 -
 - the same index, exposed by haddock library, could also serve to
 - implement commandline doc lookup, as requested in
 - http://hackage.haskell.org/trac/ghc/ticket/2168
 -}
module Main where

import System.Environment
import Data.List
import Data.Maybe(catMaybes)
import Data.Char(toUpper,isAlpha,isAscii,isAlphaNum,ord)
import qualified Data.Map as Map

import qualified OccName
import qualified Name
import qualified Module
import qualified Packages
import qualified DynFlags
import MonadUtils(liftIO)
import qualified GHC

import qualified GHC.Paths as Paths
import qualified Distribution.InstalledPackageInfo as PI
import Documentation.Haddock(freshNameCache
                            ,ifInstalledIfaces
                            ,readInterfaceFile
                            ,InstalledInterface
                            ,instVisibleExports
                            ,instExports
                            ,instDocMap
                            ,instMod
                            ,Doc(..)
                            ,exampleExpression
                            ,exampleResult)

instance Show Name.Name         where show name  = Name.getOccString name
instance Show Module.PackageId  where show pid   = Module.packageIdString pid
instance Show Module.ModuleName where show mname = Module.moduleNameString mname

main = do
  flagArgs <- getArgs
  (withDocs,args) <- getOptsArgs (False,flagArgs)
  iffs <- readInterfaceFiles freshNameCache 
            [ parseIfaceOption interfaceFile
            | interfaceFile <- args ]
  (pathMap,ifaces) <- processFile Map.empty [] iffs
  let id_index = index ifaces
  mapM_ (printElt pathMap withDocs . indexElt) $ id_index

-- file parameters come in htmldir,interfacefile format for each
-- package; extract Map from package id to htmldir, pass on plain
-- interfacefile list
processFile m ifs []                      
  = return (m,concat ifs)
processFile m ifs (((path,_),file):files)
  = processFile (Map.insert package path m) (ifaces:ifs) files
  where ifaces@(iface:_) = ifInstalledIfaces file 
        package = Module.modulePackageId $ instMod iface

-- process options, optionally fetch ghc-pkg info
getOptsArgs (withDocs,("--installed":args)) = do
  installedHaddocks <- haddockPaths
  getOptsArgs (withDocs,args++installedHaddocks)
getOptsArgs (withDocs,("--withDocs":args)) = 
  getOptsArgs (True,args)
getOptsArgs optargs                        = 
  return optargs

-- using GHC API to access ghc-pkg database for ghc installed packages, 
-- get the paths to their .haddock interface files, prefixed with their
-- haddock HTML dirs: package-htmldir,package.haddock
haddockPaths = GHC.runGhc (Just Paths.libdir) $ do
  dflags <- GHC.getSessionDynFlags
  (dflags,pkgids) <- liftIO $ Packages.initPackages dflags
  case DynFlags.pkgDatabase dflags of
    Nothing    -> return []
    Just pkgDB -> return $ concatMap package pkgDB
  where
  package pkg = case (PI.haddockInterfaces pkg,PI.haddockHTMLs pkg) of
                  ([iface],[html]) -> [html++","++iface]
                  _                -> [] -- TODO: any other useable cases?

-- construct list of Module, Url, Doc comments for all exposed entries
indexElt (nm,entities) = (nm,map links $ Map.toAscList entities)
links (nm,entries) = [ ( mdl
                       , moduleNameUrl mdl (Name.nameOccName nm)
                       , doc
                       )
                     | (mdl,doc,True) <- entries ] 

-- simple text format:
--
-- name
--  module1 : url1
--  module2 : url2
--  ..
printElt pathMap withDoc (nm,modules) = do 
  putStrLn nm  
  mapM_ (printModule pathMap withDoc) $ concat modules

printModule pathMap withDoc (mdl,url,doc) =
  putStrLn $ "  "++mdl_name++" : "++normalize ((pathMap Map.! package)++"/"++url)
           ++if withDoc
             then "\n"++maybe "none" id doc++"\n"
             else ""
  where mdl_name = Module.moduleNameString $ Module.moduleName mdl
        package  = Module.modulePackageId mdl
        -- lets not get confused by Windows backslashes
        normalize ('\\':'\\':rest) = '/':normalize rest
        normalize ('\\':rest)      = '/':normalize rest
        normalize (c:rest)         = c:normalize rest
        normalize []               = []

-- TODO: proper formatting, perhaps the --hoogle pretty-print code?
-- comments are also in .haddock - interesting possibilities..
-- for now, just dump them out somehow
showDoc (DocEmpty)            = ""
showDoc (DocAppend a b)       = showDoc a ++ showDoc b 
showDoc (DocString s)         = s
showDoc (DocParagraph p)      = "\n"++showDoc p++"\n"
showDoc (DocIdentifier ids)   = concat [show id++" "|id<-ids]
showDoc (DocModule s)         = s
showDoc (DocEmphasis d)       = showDoc d
showDoc (DocMonospaced d)     = showDoc d
showDoc (DocUnorderedList ds) = concatMap showDoc ds
showDoc (DocOrderedList ds)   = concatMap showDoc ds
showDoc (DocDefList dds)      = concat [showDoc a++showDoc b|(a,b)<-dds]
showDoc (DocCodeBlock d)      = showDoc d
showDoc (DocURL s)            = s
showDoc (DocPic s)            = s
showDoc (DocAName s)          = s
showDoc (DocExamples es)      = concatMap showExample es

showExample e = exampleExpression e++concat (exampleResult e)

---------------------------------------------------------------------
-- the rest is cannibalized from haddock,
-- where it should be exported in some form or other
--
-- roughly, we'd need:
-- - build haddock index (similar to most backends, --gen-index)
-- - construct URLs (hidden in XHtml backend)
-- - pretty-print comments to text (similar to Hoogle backend)
--
-- the hidden global xref variables aren't helping, either
---------------------------------------------------------------------

parseIfaceOption str =
  case break (==',') str of
    (fpath, ',':rest) ->
      case break (==',') rest of
        (src, ',':file) -> ((fpath, Just src), file)
        (file, _) -> ((fpath, Nothing), file)
    (file, _) -> (("", Nothing), file)

readInterfaceFiles name_cache_accessor pairs = do
  mbPackages <- mapM tryReadIface pairs
  return (catMaybes mbPackages)
  where
    -- try to read an interface, warn if we can't
    tryReadIface (paths, file) = do
      eIface <- readInterfaceFile name_cache_accessor file
      case eIface of
        Left err -> do
          putStrLn ("Warning: Cannot read " ++ file ++ ":")
          putStrLn ("   " ++ err)
          putStrLn "Skipping this interface."
          return Nothing
        Right f -> return $ Just (paths, f)

-- for each name (a plain string), we have a number of original HsNames that
-- it can refer to, and for each of those we have a list of modules
-- that export that entity.  Each of the modules exports the entity
-- in a visible or invisible way (hence the Bool).
full_index :: [InstalledInterface] 
           -> Map.Map String (Map.Map Name.Name [(Module.Module,Maybe String,Bool)])
full_index ifaces = Map.fromListWith (flip (Map.unionWith (++)))
                     (concat (map getIfaceIndex ifaces))

index :: [InstalledInterface] 
      -> [(String, Map.Map Name.Name [(Module.Module,Maybe String,Bool)])]
index ifaces = sortBy cmp $ Map.toAscList $ full_index ifaces
  where cmp (n1,_) (n2,_) = map toUpper n1 `compare` map toUpper n2

getIfaceIndex iface = 
  [ (Name.getOccString name
     , Map.fromList [(name, [(mdl, fmap showD $ name `Map.lookup` docMap
                                 , name `elem` instVisibleExports iface)])])
     | name <- instExports iface
     , let docMap = instDocMap iface ]
  where mdl = instMod iface
        showD (mbDoc,fnargsDoc) = maybe "none" showDoc mbDoc

moduleNameUrl mdl nm = moduleHtmlFile mdl ++ '#' : nameAnchorId nm
moduleHtmlFile mdl = mdl' ++ ".html"
  where
  mdl' = map (\c -> if c == '.' then '-' else c)
             (Module.moduleNameString (Module.moduleName mdl))

nameAnchorId name = makeAnchorId (prefix : ':' : OccName.occNameString name)
 where prefix | OccName.isValOcc name = 'v'
              | otherwise             = 't'

makeAnchorId :: String -> String
makeAnchorId [] = []
makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r
  where
    escape p c | p c = [c]
               | otherwise = '-' : (show (ord c)) ++ "-"
    isLegal ':' = True
    isLegal '_' = True
    isLegal '.' = True
    isLegal c = isAscii c && isAlphaNum c
       -- NB: '-' is legal in IDs, but we use it as the escape char