{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- Module      :  Haddock.Utils
-- Copyright   :  (c) The University of Glasgow 2001-2002,
--                    Simon Marlow 2003-2006,
--                    David Waern  2006-2009
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
module Haddock.Utils
  ( -- * Filename utilities
    moduleHtmlFile
  , moduleHtmlFile'
  , contentsHtmlFile
  , indexHtmlFile
  , indexJsonFile
  , subIndexHtmlFile
  , haddockJsFile
  , jsQuickJumpFile
  , quickJumpCssFile

    -- * Anchor and URL utilities
  , moduleNameUrl
  , moduleNameUrl'
  , moduleUrl
  , nameAnchorId
  , makeAnchorId

    -- * Miscellaneous utilities
  , getProgramName
  , bye
  , die
  , escapeStr
  , writeUtf8File
  , withTempDir

    -- * HTML cross reference mapping
  , html_xrefs_ref
  , html_xrefs_ref'

    -- * Doc markup
  , mkMeta

    -- * List utilities
  , replace
  , spanWith

    -- * Logging
  , parseVerbosity
  , Verbosity (..)
  , silent
  , normal
  , verbose
  , deafening
  , out
  ) where

import Control.Monad.Catch (MonadMask, bracket_)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Char (chr, isAlpha, isAlphaNum, isAscii, ord)
import Data.IORef (IORef, newIORef, readIORef)
import Data.List (isSuffixOf)
import Data.Map (Map)
import qualified Data.Map as Map hiding (Map)
import GHC
import GHC.Types.Name
import Numeric (showIntAtBase)
import System.Directory (createDirectory, removeDirectoryRecursive)
import System.Environment (getProgName)
import System.Exit
import qualified System.FilePath.Posix as HtmlPath
import System.IO (IOMode (..), hPutStr, hSetEncoding, utf8, withFile)
import System.IO.Unsafe (unsafePerformIO)

import Documentation.Haddock.Doc (emptyMetaDoc)
import Haddock.Types

--------------------------------------------------------------------------------

-- * Logging

--------------------------------------------------------------------------------

data Verbosity = Silent | Normal | Verbose | Deafening
  deriving (Eq, Ord, Enum, Bounded, Show)

silent, normal, verbose, deafening :: Verbosity
silent = Silent
normal = Normal
verbose = Verbose
deafening = Deafening

-- | Parse out a verbosity level. Inspired from Cabal's verbosity parsing.
parseVerbosity :: String -> Either String Verbosity
parseVerbosity "0" = Right Silent
parseVerbosity "1" = Right Normal
parseVerbosity "2" = Right Verbose
parseVerbosity "3" = Right Deafening
parseVerbosity "silent" = return Silent
parseVerbosity "normal" = return Normal
parseVerbosity "verbose" = return Verbose
parseVerbosity "debug" = return Deafening
parseVerbosity "deafening" = return Deafening
parseVerbosity other = Left ("Can't parse verbosity " ++ other)

-- | Print a message to stdout, if it is not too verbose
out
  :: MonadIO m
  => Verbosity
  -- ^ program verbosity
  -> Verbosity
  -- ^ message verbosity
  -> String
  -> m ()
out progVerbosity msgVerbosity msg
  | msgVerbosity <= progVerbosity = liftIO $ putStrLn msg
  | otherwise = return ()

--------------------------------------------------------------------------------

-- * Some Utilities

--------------------------------------------------------------------------------

mkMeta :: Doc a -> MDoc a
mkMeta x = emptyMetaDoc{_doc = x}

--------------------------------------------------------------------------------

-- * Filename mangling functions stolen from s main/DriverUtil.lhs.

--------------------------------------------------------------------------------

baseName :: ModuleName -> FilePath
baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString

moduleHtmlFile :: Module -> FilePath
moduleHtmlFile mdl =
  case Map.lookup mdl html_xrefs of
    Nothing -> baseName mdl' ++ ".html"
    Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl' ++ ".html"]
  where
    mdl' = moduleName mdl

moduleHtmlFile' :: ModuleName -> FilePath
moduleHtmlFile' mdl =
  case Map.lookup mdl html_xrefs' of
    Nothing -> baseName mdl ++ ".html"
    Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl ++ ".html"]

contentsHtmlFile, indexHtmlFile, indexJsonFile :: String
contentsHtmlFile = "index.html"
indexHtmlFile = "doc-index.html"
indexJsonFile = "doc-index.json"

subIndexHtmlFile :: String -> String
subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html"
  where
    b
      | all isAlpha ls = ls
      | otherwise = concatMap (show . ord) ls

-------------------------------------------------------------------------------

-- * Anchor and URL utilities

--
-- NB: Anchor IDs, used as the destination of a link within a document must
-- conform to XML's NAME production. That, taken with XHTML and HTML 4.01's
-- various needs and compatibility constraints, means these IDs have to match:
--      [A-Za-z][A-Za-z0-9:_.-]*
-- Such IDs do not need to be escaped in any way when used as the fragment part
-- of a URL. Indeed, %-escaping them can lead to compatibility issues as it
-- isn't clear if such fragment identifiers should, or should not be unescaped
-- before being matched with IDs in the target document.
-------------------------------------------------------------------------------

moduleUrl :: Module -> String
moduleUrl = moduleHtmlFile

moduleNameUrl :: Module -> OccName -> String
moduleNameUrl mdl n = moduleUrl mdl ++ '#' : nameAnchorId n

moduleNameUrl' :: ModuleName -> OccName -> String
moduleNameUrl' mdl n = moduleHtmlFile' mdl ++ '#' : nameAnchorId n

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

-- | Takes an arbitrary string and makes it a valid anchor ID. The mapping is
-- identity preserving.
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

-------------------------------------------------------------------------------

-- * Files we need to copy from our $libdir

-------------------------------------------------------------------------------

haddockJsFile :: String
haddockJsFile = "haddock-bundle.min.js"

jsQuickJumpFile :: String
jsQuickJumpFile = "quick-jump.min.js"

quickJumpCssFile :: String
quickJumpCssFile = "quick-jump.css"

-------------------------------------------------------------------------------

-- * Misc.

-------------------------------------------------------------------------------

getProgramName :: IO String
getProgramName = fmap (`withoutSuffix` ".bin") getProgName
  where
    str `withoutSuffix` suff
      | suff `isSuffixOf` str = take (length str - length suff) str
      | otherwise = str

bye :: String -> IO a
bye s = putStr s >> exitSuccess

escapeStr :: String -> String
escapeStr = escapeURIString isUnreserved

-- Following few functions are copy'n'pasted from Network.URI module
-- to avoid depending on the network lib, since doing so gives a
-- circular build dependency between haddock and network
-- (at least if you want to build network with haddock docs)
escapeURIChar :: (Char -> Bool) -> Char -> String
escapeURIChar p c
  | p c = [c]
  | otherwise = '%' : myShowHex (ord c) ""
  where
    myShowHex :: Int -> ShowS
    myShowHex n r = case showIntAtBase 16 toChrHex n r of
      [] -> "00"
      [a] -> ['0', a]
      cs -> cs
    toChrHex d
      | d < 10 = chr (ord '0' + fromIntegral d)
      | otherwise = chr (ord 'A' + fromIntegral (d - 10))

escapeURIString :: (Char -> Bool) -> String -> String
escapeURIString = concatMap . escapeURIChar

isUnreserved :: Char -> Bool
isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~")

isAlphaChar, isDigitChar, isAlphaNumChar :: Char -> Bool
isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')
isDigitChar c = c >= '0' && c <= '9'
isAlphaNumChar c = isAlphaChar c || isDigitChar c

-- | Utility to write output to UTF-8 encoded files.
--
-- The problem with 'writeFile' is that it picks up its 'TextEncoding' from
-- 'getLocaleEncoding', and on some platforms (like Windows) this default
-- encoding isn't enough for the characters we want to write.
writeUtf8File :: FilePath -> String -> IO ()
writeUtf8File filepath contents = withFile filepath WriteMode $ \h -> do
  hSetEncoding h utf8
  hPutStr h contents

withTempDir :: (MonadIO m, MonadMask m) => FilePath -> m a -> m a
withTempDir dir =
  bracket_
    (liftIO $ createDirectory dir)
    (liftIO $ removeDirectoryRecursive dir)

-----------------------------------------------------------------------------

-- * HTML cross references

--
-- For each module, we need to know where its HTML documentation lives
-- so that we can point hyperlinks to it.  It is extremely
-- inconvenient to plumb this information to all the places that need
-- it (basically every function in HaddockHtml), and furthermore the
-- mapping is constant for any single run of Haddock.  So for the time
-- being I'm going to use a write-once global variable.
-----------------------------------------------------------------------------

{-# NOINLINE html_xrefs_ref #-}
html_xrefs_ref :: IORef (Map Module FilePath)
html_xrefs_ref = unsafePerformIO (newIORef (error "module_map"))

{-# NOINLINE html_xrefs_ref' #-}
html_xrefs_ref' :: IORef (Map ModuleName FilePath)
html_xrefs_ref' = unsafePerformIO (newIORef (error "module_map"))

{-# NOINLINE html_xrefs #-}
html_xrefs :: Map Module FilePath
html_xrefs = unsafePerformIO (readIORef html_xrefs_ref)

{-# NOINLINE html_xrefs' #-}
html_xrefs' :: Map ModuleName FilePath
html_xrefs' = unsafePerformIO (readIORef html_xrefs_ref')

-----------------------------------------------------------------------------

-- * List utils

-----------------------------------------------------------------------------

replace :: Eq a => a -> a -> [a] -> [a]
replace a b = map (\x -> if x == a then b else x)

spanWith :: (a -> Maybe b) -> [a] -> ([b], [a])
spanWith _ [] = ([], [])
spanWith p xs@(a : as)
  | Just b <- p a = let (bs, cs) = spanWith p as in (b : bs, cs)
  | otherwise = ([], xs)
