{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS -fno-warn-name-shadowing #-}
import Options.Applicative
import Cabal.Simple
import Cabal.Haddock
import Data.Monoid
import qualified Data.Set as Set
import Text.Printf
import System.Directory
import System.FilePath
import Data.Foldable (forM_)

import Distribution.Simple.Compiler hiding (Flag)
import Distribution.Package --must not specify imports, since we're exporting moule.
import Distribution.PackageDescription
import Distribution.PackageDescription.Parsec
import Distribution.Simple.Program
import Distribution.Simple.Setup
import qualified Distribution.Simple.Setup as Setup
import Distribution.Simple.Utils hiding (info)
import Distribution.Verbosity
import Distribution.Text

data SHFlags = SHFlags
    { shPkgDbArgs       :: [String]
    , shCompiler        :: Maybe String
    , shDistDir         :: Maybe String
    , shHyperlinkSource :: Bool
    , shVerbosity       :: Verbosity
    , shDest            :: String
    , shPkgDirs         :: [String]
    }

optParser :: Parser SHFlags
optParser =
  SHFlags
    <$> many (strOption (long "package-db" <> metavar "DB-PATH" <> help "Additional package database"))
    <*> optional (strOption (long "compiler-exe" <> metavar "EXE-PATH" <> help "Compiler binary"))
    <*> optional (strOption (long "dist-dir" <> metavar "DIST-PATH" <> help "Dist work directory"))
    <*> switch (long "hyperlink-source" <> help "Generate source links in documentation")
    <*> option ( auto >>= maybe (readerError "Bad verbosity") return . intToVerbosity )
      (  long "verbosity"
      <> short 'v'
      <> value normal
      <> metavar "N"
      <> help "Verbosity (number from 0 to 3)"
        )
    <*> strOption (short 'o' <> metavar "OUTPUT-PATH" <> help "Directory where html files will be placed")
    <*> many (argument str (metavar "PACKAGE-PATH"))

getPackageNames
  :: Verbosity
  -> [FilePath]       -- ^ package directories
  -> IO [PackageName] -- ^ package names
getPackageNames v = mapM $ \dir -> do
  cabalFile <- either error id <$> findPackageDesc dir
  desc <- readGenericPackageDescription v cabalFile
  let
    name = pkgName . package . packageDescription $ desc
  return name

-- Depending on whether PackageId refers to a "local" package, return
-- a relative path or the hackage url
computePath :: [PackageName] -> (PackageId -> FilePath)
computePath names =
  let pkgSet = Set.fromList names in \pkgId ->

  if pkgName pkgId `Set.member` pkgSet
    then
      ".." </> (display $ pkgName pkgId)
    else
      printf "http://hackage.haskell.org/packages/archive/%s/%s/doc/html"
        (display $ pkgName pkgId)
        (display $ pkgVersion pkgId)

main :: IO ()
main = do
  SHFlags{..} <- execParser $
    info (helper <*> optParser) idm

  -- make all paths absolute, since we'll be changing directories
  -- but first create dest — canonicalizePath will throw an exception if
  -- it's not there
  createDirectoryIfMissing True {- also parents -} shDest
  shDest <- canonicalizePath shDest
  shPkgDirs <- mapM canonicalizePath shPkgDirs

  pkgNames <- getPackageNames shVerbosity shPkgDirs

  let
    defaultFlags =
      (defaultConfigFlags defaultProgramConfiguration)
    configFlags =
      defaultFlags
        { configPackageDBs = map (Just . SpecificPackageDB) shPkgDbArgs
        , configVerbosity = Setup.Flag shVerbosity
        , configDistPref = maybe (configDistPref defaultFlags) Setup.Flag shDistDir
        , configHcPath = maybe (configHcPath defaultFlags) Setup.Flag shCompiler
        }
    haddockFlags =
      defaultHaddockFlags
        { haddockDistPref = Setup.Flag shDest
        , haddockLinkedSource = Setup.Flag shHyperlinkSource
        }

  -- generate docs for every package
  forM_ shPkgDirs $ \dir -> do
    setCurrentDirectory dir

    lbi <- configureAction simpleUserHooks configFlags []
    haddockAction lbi simpleUserHooks haddockFlags [] (computePath pkgNames)

  -- generate documentation index
  regenerateHaddockIndex normal defaultProgramConfiguration shDest
    [(iface, html)
    | pkg <- pkgNames
    , let pkgStr = display pkg
          html = pkgStr
          iface = shDest </> pkgStr </> pkgStr <.> "haddock"
    ]