-- | 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.Program.Db (userSpecifyArgs)
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
import System.Info

-- ----------------------------------------------------------------------
-- * 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, 
             
  -- | Bootstrapping mode. Required to generate Superdoc's own
  -- documentation, because at that point, Superdoc is typically not
  -- yet installed. Other packages using Superdoc should not set this
  -- flag.
  bootstrap :: Bool
} 
  deriving (Show, Eq)

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

-- | 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-html-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 hook for Haddock
  
-- | A hook for Haddock. This simply adds a command line option to the
-- subordinate Haddock process, instructing it to use the
-- @superdoc-armor@ preprocessor. Its purpose is to replace
-- UTF8-encoded Unicode characters by their ASCII armor.
haddockhook :: SuperdocArgs -> PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO ()
haddockhook sdargs desc info hooks flags = do 
  -- Add preprocessor arguments to haddock
  let progs = withPrograms info
  let progs' = userSpecifyArgs "haddock" hargs progs
  let info' = info { withPrograms = progs' }

  let args = haddockProgramArgs flags
  let args' = args ++ [("haddock", hargs)]
  let flags' = flags { haddockProgramArgs = args' }

  -- Run the default handler, with the modified arguments
  haddockHook simpleUserHooks desc info' hooks flags'
  where
   hargs 
     | bootstrap sdargs == False = 
       ["--optghc=-F", "--optghc=-pgmF", "--optghc=superdoc-armor"]
     | os == "mingw32" =
       ["--optghc=-F", "--optghc=-pgmF", "--optghc=scripts/preproc.bat"]
     | otherwise =
       ["--optghc=-F", "--optghc=-pgmF", "--optghc=scripts/preproc.sh"]

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

-- | A hook to run after Haddock completes. This resolves Superdoc
-- markup and ASCII armor 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 hold 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.  
  when (haddockHscolour flags == Flag True) $ do
    do_posthscolour docdir

  -- 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 ()