{-# LANGUAGE CPP #-}

-- | This module defines Superdoc's parameters, as well as the Cabal
-- user hooks that do Superdoc's \"real\" work. For an explanation of
-- what that work is, see here: "Distribution.Superdoc#HOWITWORKS".
-- 
-- Further, this module exposes some low-level functions that are not
-- exposed in "Distribution.Superdoc", but that may be useful for some
-- specialized applications.

module Distribution.Superdoc.Hooks where

import Distribution.Superdoc.Markup
import Distribution.Superdoc.UTF8

import Distribution.Simple
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Setup
import Distribution.PackageDescription (PackageDescription(..))

import Data.List
import Control.Exception (throwIO)
import Control.Monad (when)
import qualified Data.Set as Set
import Data.Set (Set)
import System.Directory
import System.FilePath

-- ----------------------------------------------------------------------
-- * Superdoc parameters

-- | A data structure to hold Superdoc's parameters. Additional
-- parameters may be added in the future, so to ensure forward
-- compatibility, packages should always specify parameters by
-- modifying 'defaultSuperdocArgs', for example like this:
-- 
-- > let params = defaultSuperdocArgs { imageSource = ... }
data SuperdocArgs = SuperdocArgs {
  -- | Where to look for image files.
  imageSource :: ImageSource,   
  
  -- | What to do about missing image files.
  imageMissing :: ImageMissing
} 
  deriving (Show, Eq)

-- | The default Superdoc parameters.
defaultSuperdocArgs :: SuperdocArgs
defaultSuperdocArgs = SuperdocArgs {
  imageSource = CopyFrom "images",
  imageMissing = FailOnMissing
} 

-- | This parameter specifies where to find image files that are
-- linked to in the documentation.
data ImageSource = 
  CopyFrom FilePath
    -- ^ Copy image files from the specified source directory, which
    -- is relative to the package root. The default is \"@images@\".
    -- Superdoc will copy the required images to their appropriate
    -- location within the generated HTML documentation. The image
    -- files should also be declared as @extra-source-files@ in the
    -- @.cabal@ file.

  | ExtraHtmlFiles
    -- ^ Assume the images are already present in the directory where
    -- the Haddock documentation is being generated. This is useful if
    -- the images have been declared as @extra-doc-files@ in the
    -- @.cabal@ file. They will then have been copied to their
    -- rightful location by Cabal. Superdoc will check that the
    -- required images are present.
  deriving (Show, Eq)
    
-- | This parameter specifies what to do when the documentation links
-- to an image that does not exist.
data ImageMissing =
  FailOnMissing
    -- ^ This is the default setting. Cabal will fail with an error
    -- message if the documentation links to an image that does not
    -- exist or cannot be found.

  | IgnoreMissing
    -- ^ Ignore missing image files. Superdoc will still generate HTML
    -- image tags, but will not fail if a corresponding image file
    -- does not exist.  This setting may be useful for testing, or to
    -- build documentation when the image files are incomplete or
    -- missing.  It is not recommended to use this setting for
    -- production purposes.
  deriving (Show, Eq)
  
-- ----------------------------------------------------------------------
-- * Hooks for the setup program

-- ----------------------------------------------------------------------
-- ** A post-Haddock hook

-- | A hook to run after Haddock completes. This resolves Superdoc
-- markup in all generated HTML files. It also copies all of the
-- linked images to the HTML directory (depending on the 'imageSource'
-- and 'imageMissing' parameters). Finally, it checks for the
-- \"@--hyperlink-source@\" option, and if necessary, calls the
-- 'posthscolour' hook as well (because it is not run from inside
-- Cabal in this situation).
-- 
-- The first argument holds the Superdoc parameters, and the remaining
-- arguments are as for any 'postHaddock' hook.
posthaddock :: SuperdocArgs -> Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO ()
posthaddock sdargs args flags desc info = do
  
  -- Find documentation's build directory
  let package_name = unPackageName (pkgName (package desc))
  let distdir = case haddockDistPref flags of
        Flag distdir -> distdir
        NoFlag -> buildDir info </> ".."
  let docdir = distdir </> "doc" </> "html" </> package_name
  
  -- Although the --hyperlink-source option causes HsColour to be run,
  -- it fails to run the postHscolour hook. So we run it explicitly.  
#if MIN_VERSION_Cabal(2,2,0)
  when (haddockLinkedSource flags == Flag True) $ do
    do_posthscolour docdir
#else
  when (haddockHscolour flags == Flag True) $ do
    do_posthscolour docdir
#endif
    
  -- Now do the actual work.
  do_posthaddock sdargs docdir
  
-- | Do the actual work of the 'posthaddock' hook, given a path to the
-- documentation directory.
do_posthaddock :: SuperdocArgs -> FilePath -> IO ()
do_posthaddock sdargs docdir = do                
  
  -- Make a list of HTML files.
  files <- getDirectoryContents docdir
  let htmlfiles = [ docdir </> f | f <- files, ".html" `isSuffixOf` f ]
  
  -- Process them.
  imagelist <- filter_files markup htmlfiles
  let images = Set.unions imagelist
  
  handle_images (imageSource sdargs) (imageMissing sdargs) images docdir
  
-- | Perform the action described by 'ImageSource' and 'ImageMissing',
-- for the given set of images. The last argument is the path for the
-- documentation directory.
handle_images :: ImageSource -> ImageMissing -> Set FilePath -> FilePath -> IO ()
handle_images ExtraHtmlFiles IgnoreMissing images docdir = return ()
handle_images ExtraHtmlFiles FailOnMissing images docdir = do
  sequence_ $ do
    f <- Set.toList images
    return $ do
      exists <- doesFileExist (docdir </> f)
      when (not exists) $ do
        throwIO (userError (f ++ ": does not exist"))
handle_images (CopyFrom imagedir) flag images docdir = do
  -- Copy the required image files to the HTML directory. If flag ==
  -- FailOnMissing, raise an IO error if some image is not present.
  sequence_ $ do
    f <- Set.toList images
    return $ do
      exists_src <- doesFileExist (imagedir </> f)
      if exists_src then do
          copyFile (imagedir </> f) (docdir </> f)
        else if flag == IgnoreMissing then do
          return ()
        else
          throwIO (userError (f ++ ": does not exist"))

-- ----------------------------------------------------------------------
-- ** A post-HsColour hook

-- | A hook to run after HsColour completes. This goes through the
-- files generated by HsColour and replaces UTF8 characters by their
-- corresponding HTML escapes.
posthscolour :: SuperdocArgs -> Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO ()
posthscolour sdargs args flags desc info = do
  
  -- Find documentation's build directory
  let package_name = unPackageName (pkgName (package desc))
  let distdir = case hscolourDistPref flags of
        Flag distdir -> distdir
        NoFlag -> buildDir info </> ".."
  let docdir = distdir </> "doc" </> "html" </> package_name
  do_posthscolour docdir
  
-- | Do the actual work of the 'posthaddock' hook, given a path to the
-- documentation directory.
do_posthscolour :: FilePath -> IO ()
do_posthscolour docdir = do  
  let hscolourdir = docdir </> "src"
  
  -- Make a list of HTML files.
  files <- getDirectoryContents hscolourdir
  let htmlfiles = [ hscolourdir </> f | f <- files, ".html" `isSuffixOf` f ]
  
  -- Process them.
  filter_files (filter_id . to_html . parse_utf8) htmlfiles
  return ()