aboutsummaryrefslogblamecommitdiff
path: root/src/Main.hs
blob: f80e118b0ea97ac4deec1748c7636ff5dafea4dd (plain) (tree)
1
2
3
4
5
6
7
8
9
                          
                                                            

                                         
                        
                                                                        
  
 
                        
 

                              
                    
                      
                            
                      
                    
                    
 
                    


                                                  
                        
      
                 
                                

                         
                      
                             
                            

                

                   
                
      
 
                                         
                                 
                                 

                           
 
 
                                                                                
                     
                                                                                
 
                                   

                                                                        
 
                                      











                                                                               
 
                                       
                                







                                                           
 
 
                                   
                                                         
                             
                    
                                             
                                                
               
      
                                            



                              
                 
             

                                         
                                 

                   
 
                                                                               
            
                                                                               
 
 
             
                               
 
                                                               
                 
                                            
                       
                                 
 



                                                                    
 
                        
 

                                          
                  


                                                                
     
                                                   
      
 
                              




                                                                                 
                       
                                                                   
 
                                                                          
 
 
                                                                    
                                                                            
 
                                  
                                        
 
                                                        
                                                                             




                                                                                  
 
                                                                  
                                                                                  
                              
                                    
                                                    
                                                                         
      
                                                    
                                                                      

                                                                             
 
 

                                                                               
 
 
                                                                           
                                                                
                                        
     
                                                     
                        
                          
 

                                                                               
 

                                                                           
 
                                                 



                                                               
                                                          

                                                     
                                      


                                                      


                                                     
      


                                                   
 







                                                          
 
                               
      
                                                                            
                                                                  


                                                                              
                                                            
 
 
                                        
                                                            
                                                                    
                                
                                     
                                                                         
                                                                                 
                                           
                                                               
                                                                          
                                                       
                                     
 
                                    
                                              

                                                  
                                     
 
                                      
                                                                              
 
 
                                                                               
                                      

                                                                               



                                                   



                                                 
                                                           
                    
                               


                                                            
                                          
 
                                                                       



                                                                         
                                     

       



                                                                               
                                      
                                               
                        
 
                                                






                                               
                                  
                   

                                                   
 

                                                                     
       
                      
                                                                         
 

                                                                  
 
                                                       
                                                  
       
                                                                   
 
 
                                                   



                                                         
                                          
                                      
                                              
                                                             
















                                                           
{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE ForeignFunctionInterface, PatternSignatures #-}

--
-- Haddock - A Haskell Documentation Tool
--
-- (c) Simon Marlow 2003
-- 
-- Ported to use the GHC API by David Waern during "Summer of Code" 2006
--


module Main (main) where


import Haddock.Backends.Html
import Haddock.Backends.Hoogle
import Haddock.Interface
import Haddock.Types
import Haddock.Version
import Haddock.InterfaceFile
import Haddock.Exception
import Haddock.Options
import Haddock.GHC
import Haddock.Utils
import Paths_haddock

import Control.Monad
#if __GLASGOW_HASKELL__ >= 609
import Control.OldException
import qualified Control.Exception as NewException
#else
import Control.Exception
#endif
import Data.Maybe
import Data.IORef
import qualified Data.Map as Map
import System.IO
import System.Exit
import System.Environment
import System.FilePath
import Distribution.Verbosity

#if defined(mingw32_HOST_OS)
import Foreign
import Foreign.C
import Data.Int
#endif

#ifndef IN_GHC_TREE
import GHC.Paths
#endif

import GHC hiding (flags, verbosity)
import DynFlags hiding (flags, verbosity)
#if __GLASGOW_HASKELL__ >= 609
import Panic (handleGhcException)
import MonadUtils ( MonadIO(..) )
#else
import Util hiding (handle)
#endif


--------------------------------------------------------------------------------
-- Exception handling
--------------------------------------------------------------------------------


handleTopExceptions :: IO a -> IO a
handleTopExceptions = 
  handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions


handleNormalExceptions :: IO a -> IO a
handleNormalExceptions inner =
  handle (\exception -> do
    hFlush stdout    
    case exception of
      AsyncException StackOverflow -> do
        putStrLn "stack overflow: use -g +RTS -K<size> to increase it"
        exitFailure
      ExitException code -> exitWith code
      _other -> do
        putStrLn ("haddock: internal Haddock or GHC error: " ++ show exception)
        exitFailure
  ) inner


handleHaddockExceptions :: IO a -> IO a
handleHaddockExceptions inner = 
#if __GLASGOW_HASKELL__ >= 609
  NewException.catches inner [NewException.Handler handler]
#else
  handleDyn handler inner
#endif
  where
    handler (e::HaddockException) = do
      putStrLn $ "haddock: " ++ (show e)
      exitFailure


handleGhcExceptions :: IO a -> IO a
handleGhcExceptions inner = 
  -- compilation errors: messages with locations attached
#if __GLASGOW_HASKELL__ < 609
 handleDyn (\e -> do
    putStrLn "haddock: Compilation error(s):"
    printBagOfErrors defaultDynFlags (unitBag e)
    exitFailure
  ) $
#endif

  -- error messages propagated as exceptions
#if __GLASGOW_HASKELL__ >= 609
  handleGhcException (\e -> do
#else
  handleDyn (\e -> do
#endif
    hFlush stdout
    case e of
      PhaseFailed _ code -> exitWith code
      Interrupted -> exitFailure
      _ -> do 
        print (e :: GhcException)
        exitFailure
  ) inner


-------------------------------------------------------------------------------
-- Top level
-------------------------------------------------------------------------------


main :: IO ()
main = handleTopExceptions $ do

  -- parse command-line flags and handle some of them initially
  args <- getArgs
  (flags, fileArgs) <- parseHaddockOpts args
  handleEasyFlags flags
  verbosity <- getVerbosity flags

  let renderStep packages interfaces = do 
        updateHTMLXRefs packages
        let ifaceFiles = map fst packages
            installedIfaces = concatMap ifInstalledIfaces ifaceFiles
        render flags interfaces installedIfaces

  if not (null fileArgs)
    then do

      libDir <- case getGhcLibDir flags of
                Just dir -> return dir
                Nothing ->
#ifdef IN_GHC_TREE
                    do m <- getExecDir
                       case m of
                           Nothing -> error "No GhcLibDir found"
                           Just d -> return (d </> "..")
#else
                    return libdir -- from GHC.Paths
#endif

#if __GLASGOW_HASKELL__ >= 609
      -- We have one global error handler for all GHC source errors.  Other kinds
      -- of exceptions will be propagated to the top-level error handler. 
      let handleSrcErrors action = flip handleSourceError action $ \err -> do
            printExceptionAndWarnings err
            liftIO exitFailure

      -- initialize GHC
      startGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do

        -- get packages supplied with --read-interface
        packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags)


        -- create the interfaces -- this is the core part of Haddock
        (interfaces, homeLinks) <- createInterfaces verbosity fileArgs flags
                                                    (map fst packages)

        liftIO $ do
          -- render the interfaces
          renderStep packages interfaces
 
          -- last but not least, dump the interface file
          dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags
#else
      -- initialize GHC
      (session, dynflags) <- startGhc libDir (ghcFlags flags)

      -- get packages supplied with --read-interface
      packages <- readInterfaceFiles (nameCacheFromGhc session) (ifacePairs flags)

      -- create the interfaces -- this is the core part of Haddock
      (interfaces, homeLinks) <- createInterfaces verbosity session fileArgs flags
                                                  (map fst packages)

      -- render the interfaces
      renderStep packages interfaces
 
      -- last but not least, dump the interface file
      dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags
#endif
    else do
      -- get packages supplied with --read-interface
      packages <- readInterfaceFiles freshNameCache (ifacePairs flags)

      -- render even though there are no input files (usually contents/index)
      renderStep packages []


-------------------------------------------------------------------------------
-- Rendering
-------------------------------------------------------------------------------


-- | Render the interfaces with whatever backend is specified in the flags 
render :: [Flag] -> [Interface] -> [InstalledInterface] -> IO ()
render flags ifaces installedIfaces = do
  let
    title = case [str | Flag_Heading str <- flags] of
		[] -> ""
		(t:_) -> t

    maybe_source_urls = (listToMaybe [str | Flag_SourceBaseURL   str <- flags]
                        ,listToMaybe [str | Flag_SourceModuleURL str <- flags]
                        ,listToMaybe [str | Flag_SourceEntityURL str <- flags])

    maybe_wiki_urls = (listToMaybe [str | Flag_WikiBaseURL   str <- flags]
                      ,listToMaybe [str | Flag_WikiModuleURL str <- flags]
                      ,listToMaybe [str | Flag_WikiEntityURL str <- flags])

  libDir <- case [str | Flag_Lib str <- flags] of
		[] ->
#ifdef IN_GHC_TREE
                      do m <- getExecDir
                         case m of
                             Nothing -> error "No libdir found"
                             Just d -> return (d </> "..")
#else
                      getDataDir -- provided by Cabal
#endif
		fs -> return (last fs)

  let css_file = case [str | Flag_CSS str <- flags] of
			[] -> Nothing
			fs -> Just (last fs)

  odir <- case [str | Flag_OutputDir str <- flags] of
		[] -> return "."
		fs -> return (last fs)

  let 
    maybe_contents_url = 
      case [url | Flag_UseContents url <- flags] of
        [] -> Nothing
        us -> Just (last us)

    maybe_index_url = 
      case [url | Flag_UseIndex url <- flags] of
        [] -> Nothing
        us -> Just (last us)

    maybe_html_help_format =
      case [hhformat | Flag_HtmlHelp hhformat <- flags] of
        []      -> Nothing
        formats -> Just (last formats)

  prologue <- getPrologue flags

  let 
    visibleIfaces    = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]

    -- *all* visible interfaces including external package modules
    allIfaces        = map toInstalledIface ifaces ++ installedIfaces
    allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ]

    packageMod       = ifaceMod (head ifaces)
    packageStr       = Just (modulePackageString packageMod)
    (pkgName,pkgVer) = modulePackageInfo packageMod

 
  when (Flag_GenIndex `elem` flags) $ do
    ppHtmlIndex odir title packageStr maybe_html_help_format
                maybe_contents_url maybe_source_urls maybe_wiki_urls
                allVisibleIfaces
    copyHtmlBits odir libDir css_file
        
  when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do
    ppHtmlHelpFiles title packageStr visibleIfaces odir maybe_html_help_format []

  when (Flag_GenContents `elem` flags) $ do
    ppHtmlContents odir title packageStr maybe_html_help_format
	                 maybe_index_url maybe_source_urls maybe_wiki_urls
	                 allVisibleIfaces True prologue
    copyHtmlBits odir libDir css_file

  when (Flag_Html `elem` flags) $ do
    ppHtml title packageStr visibleIfaces odir
                prologue maybe_html_help_format
                maybe_source_urls maybe_wiki_urls
                maybe_contents_url maybe_index_url
    copyHtmlBits odir libDir css_file

  when (Flag_Hoogle `elem` flags) $ do
    let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName
    ppHoogle pkgName2 pkgVer title prologue visibleIfaces odir


-------------------------------------------------------------------------------
-- Reading and dumping interface files
-------------------------------------------------------------------------------


readInterfaceFiles :: MonadIO m =>
                      NameCacheAccessor m
                   -> [(FilePath, FilePath)] ->
                      m [(InterfaceFile, FilePath)]
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 (html, iface) = do
      eIface <- readInterfaceFile name_cache_accessor iface
      case eIface of
        Left err -> liftIO $ do
          putStrLn ("Warning: Cannot read " ++ iface ++ ":")
          putStrLn ("   " ++ show err)
          putStrLn "Skipping this interface."
          return Nothing
        Right f -> return $ Just (f, html)


dumpInterfaceFile :: [InstalledInterface] -> LinkEnv -> [Flag] -> IO ()
dumpInterfaceFile ifaces homeLinks flags = 
  case [str | Flag_DumpInterface str <- flags] of
    [] -> return ()
    fs -> let filename = last fs in writeInterfaceFile filename ifaceFile
  where 
    ifaceFile = InterfaceFile {
        ifInstalledIfaces = ifaces,
        ifLinkEnv         = homeLinks
      }


-------------------------------------------------------------------------------
-- Misc
-------------------------------------------------------------------------------


getGhcLibDir :: [Flag] -> Maybe String
getGhcLibDir flags =
  case [ dir | Flag_GhcLibDir dir <- flags ] of
    [] -> Nothing
    xs -> Just $ last xs


getVerbosity :: Monad m => [Flag] -> m Verbosity
getVerbosity flags =
  case [ str | Flag_Verbosity str <- flags ] of
    [] -> return normal
    x:_ -> case parseVerbosity x of
      Left e -> throwE e
      Right v -> return v


handleEasyFlags :: [Flag] -> IO ()
handleEasyFlags flags = do
  usage <- getUsage

  when (Flag_Help       `elem` flags) (bye usage)
  when (Flag_Version    `elem` flags) byeVersion
  when (Flag_GhcVersion `elem` flags) byeGhcVersion

  when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
        && Flag_Html `elem` flags) $
    throwE ("-h cannot be used with --gen-index or --gen-contents")
  where
    byeVersion = bye $
      "Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2006\n"
      ++ "Ported to use the GHC API by David Waern 2006-2008\n"

    byeGhcVersion = bye $ 
      (fromJust $ lookup "Project version" $ compilerInfo) ++ "\n"


updateHTMLXRefs :: [(InterfaceFile, FilePath)] -> IO ()
updateHTMLXRefs packages = do
  writeIORef html_xrefs_ref (Map.fromList mapping)
  where
    mapping = [ (instMod iface, html) | (ifaces, html) <- packages,
                iface <- ifInstalledIfaces ifaces ]


getPrologue :: [Flag] -> IO (Maybe (HsDoc RdrName))
getPrologue flags
  = case [filename | Flag_Prologue filename <- flags ] of
	[] -> return Nothing 
	[filename] -> do
	   str <- readFile filename
	   case parseHaddockComment str of
		Left err -> throwE err
		Right doc -> return (Just doc)
	_otherwise -> throwE "multiple -p/--prologue options"

getExecDir :: IO (Maybe String)
#if defined(mingw32_HOST_OS)
getExecDir = allocaArray len $ \buf -> do
    ret <- getModuleFileName nullPtr buf len
    if ret == 0
        then return Nothing
        else do s <- peekCString buf
                return (Just (dropFileName s))
  where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.

foreign import stdcall unsafe  "GetModuleFileNameA"
  getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
#else
getExecDir = return Nothing
#endif