{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- 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,

  -- * System tools
  getProcessID
 ) where


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

import Exception (ExceptionMonad)
import GHC
import Name

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

#ifndef mingw32_HOST_OS
import qualified System.Posix.Internals
#endif


--------------------------------------------------------------------------------
-- * Logging
--------------------------------------------------------------------------------

data Verbosity = Silent | Normal | Verbose | Deafening
  deriving (Verbosity -> Verbosity -> Bool
(Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool) -> Eq Verbosity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c== :: Verbosity -> Verbosity -> Bool
Eq, Eq Verbosity
Eq Verbosity
-> (Verbosity -> Verbosity -> Ordering)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Verbosity)
-> (Verbosity -> Verbosity -> Verbosity)
-> Ord Verbosity
Verbosity -> Verbosity -> Bool
Verbosity -> Verbosity -> Ordering
Verbosity -> Verbosity -> Verbosity
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmax :: Verbosity -> Verbosity -> Verbosity
>= :: Verbosity -> Verbosity -> Bool
$c>= :: Verbosity -> Verbosity -> Bool
> :: Verbosity -> Verbosity -> Bool
$c> :: Verbosity -> Verbosity -> Bool
<= :: Verbosity -> Verbosity -> Bool
$c<= :: Verbosity -> Verbosity -> Bool
< :: Verbosity -> Verbosity -> Bool
$c< :: Verbosity -> Verbosity -> Bool
compare :: Verbosity -> Verbosity -> Ordering
$ccompare :: Verbosity -> Verbosity -> Ordering
$cp1Ord :: Eq Verbosity
Ord, Int -> Verbosity
Verbosity -> Int
Verbosity -> [Verbosity]
Verbosity -> Verbosity
Verbosity -> Verbosity -> [Verbosity]
Verbosity -> Verbosity -> Verbosity -> [Verbosity]
(Verbosity -> Verbosity)
-> (Verbosity -> Verbosity)
-> (Int -> Verbosity)
-> (Verbosity -> Int)
-> (Verbosity -> [Verbosity])
-> (Verbosity -> Verbosity -> [Verbosity])
-> (Verbosity -> Verbosity -> [Verbosity])
-> (Verbosity -> Verbosity -> Verbosity -> [Verbosity])
-> Enum Verbosity
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Verbosity -> Verbosity -> Verbosity -> [Verbosity]
$cenumFromThenTo :: Verbosity -> Verbosity -> Verbosity -> [Verbosity]
enumFromTo :: Verbosity -> Verbosity -> [Verbosity]
$cenumFromTo :: Verbosity -> Verbosity -> [Verbosity]
enumFromThen :: Verbosity -> Verbosity -> [Verbosity]
$cenumFromThen :: Verbosity -> Verbosity -> [Verbosity]
enumFrom :: Verbosity -> [Verbosity]
$cenumFrom :: Verbosity -> [Verbosity]
fromEnum :: Verbosity -> Int
$cfromEnum :: Verbosity -> Int
toEnum :: Int -> Verbosity
$ctoEnum :: Int -> Verbosity
pred :: Verbosity -> Verbosity
$cpred :: Verbosity -> Verbosity
succ :: Verbosity -> Verbosity
$csucc :: Verbosity -> Verbosity
Enum, Verbosity
Verbosity -> Verbosity -> Bounded Verbosity
forall a. a -> a -> Bounded a
maxBound :: Verbosity
$cmaxBound :: Verbosity
minBound :: Verbosity
$cminBound :: Verbosity
Bounded, Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
(Int -> Verbosity -> ShowS)
-> (Verbosity -> String)
-> ([Verbosity] -> ShowS)
-> Show Verbosity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Verbosity] -> ShowS
$cshowList :: [Verbosity] -> ShowS
show :: Verbosity -> String
$cshow :: Verbosity -> String
showsPrec :: Int -> Verbosity -> ShowS
$cshowsPrec :: Int -> Verbosity -> ShowS
Show)

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

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

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


--------------------------------------------------------------------------------
-- * Some Utilities
--------------------------------------------------------------------------------



mkMeta :: Doc a -> MDoc a
mkMeta :: Doc a -> MDoc a
mkMeta Doc a
x = MetaDoc Any Any
forall mod id. MetaDoc mod id
emptyMetaDoc { _doc :: Doc a
_doc = Doc a
x }

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

baseName :: ModuleName -> FilePath
baseName :: ModuleName -> String
baseName = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' then Char
'-' else Char
c) ShowS -> (ModuleName -> String) -> ModuleName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
moduleNameString


moduleHtmlFile :: Module -> FilePath
moduleHtmlFile :: Module -> String
moduleHtmlFile Module
mdl =
  case Module -> Map Module String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Module
mdl Map Module String
html_xrefs of
    Maybe String
Nothing  -> ModuleName -> String
baseName ModuleName
mdl' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".html"
    Just String
fp0 -> [String] -> String
HtmlPath.joinPath [String
fp0, ModuleName -> String
baseName ModuleName
mdl' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".html"]
  where
   mdl' :: ModuleName
mdl' = Module -> ModuleName
moduleName Module
mdl


moduleHtmlFile' :: ModuleName -> FilePath
moduleHtmlFile' :: ModuleName -> String
moduleHtmlFile' ModuleName
mdl =
  case ModuleName -> Map ModuleName String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
mdl Map ModuleName String
html_xrefs' of
    Maybe String
Nothing  -> ModuleName -> String
baseName ModuleName
mdl String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".html"
    Just String
fp0 -> [String] -> String
HtmlPath.joinPath [String
fp0, ModuleName -> String
baseName ModuleName
mdl String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".html"]


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


subIndexHtmlFile :: String -> String
subIndexHtmlFile :: ShowS
subIndexHtmlFile String
ls = String
"doc-index-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".html"
   where b :: String
b | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isAlpha String
ls = String
ls
           | Bool
otherwise = (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Char -> Int) -> Char -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) String
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 :: Module -> String
moduleUrl = Module -> String
moduleHtmlFile


moduleNameUrl :: Module -> OccName -> String
moduleNameUrl :: Module -> OccName -> String
moduleNameUrl Module
mdl OccName
n = Module -> String
moduleUrl Module
mdl String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'#' Char -> ShowS
forall a. a -> [a] -> [a]
: OccName -> String
nameAnchorId OccName
n


moduleNameUrl' :: ModuleName -> OccName -> String
moduleNameUrl' :: ModuleName -> OccName -> String
moduleNameUrl' ModuleName
mdl OccName
n = ModuleName -> String
moduleHtmlFile' ModuleName
mdl String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'#' Char -> ShowS
forall a. a -> [a] -> [a]
: OccName -> String
nameAnchorId OccName
n


nameAnchorId :: OccName -> String
nameAnchorId :: OccName -> String
nameAnchorId OccName
name = ShowS
makeAnchorId (Char
prefix Char -> ShowS
forall a. a -> [a] -> [a]
: Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: OccName -> String
occNameString OccName
name)
 where prefix :: Char
prefix | OccName -> Bool
isValOcc OccName
name = Char
'v'
              | Bool
otherwise     = Char
't'


-- | Takes an arbitrary string and makes it a valid anchor ID. The mapping is
-- identity preserving.
makeAnchorId :: String -> String
makeAnchorId :: ShowS
makeAnchorId [] = []
makeAnchorId (Char
f:String
r) = (Char -> Bool) -> Char -> String
escape Char -> Bool
isAlpha Char
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Char -> Bool) -> Char -> String
escape Char -> Bool
isLegal) String
r
  where
    escape :: (Char -> Bool) -> Char -> String
escape Char -> Bool
p Char
c | Char -> Bool
p Char
c = [Char
c]
               | Bool
otherwise = Char
'-' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show (Char -> Int
ord Char
c) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-"
    isLegal :: Char -> Bool
isLegal Char
':' = Bool
True
    isLegal Char
'_' = Bool
True
    isLegal Char
'.' = Bool
True
    isLegal Char
c = Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Char -> Bool
isAlphaNum Char
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 :: String
haddockJsFile = String
"haddock-bundle.min.js"

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

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

-------------------------------------------------------------------------------
-- * Misc.
-------------------------------------------------------------------------------


getProgramName :: IO String
getProgramName :: IO String
getProgramName = ShowS -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
`withoutSuffix` String
".bin") IO String
getProgName
   where [a]
str withoutSuffix :: [a] -> [a] -> [a]
`withoutSuffix` [a]
suff
            | [a]
suff [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [a]
str = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
str Int -> Int -> Int
forall a. Num a => a -> a -> a
- [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
suff) [a]
str
            | Bool
otherwise             = [a]
str


bye :: String -> IO a
bye :: String -> IO a
bye String
s = String -> IO ()
putStr String
s IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
forall a. IO a
exitSuccess

escapeStr :: String -> String
escapeStr :: ShowS
escapeStr = (Char -> Bool) -> ShowS
escapeURIString Char -> Bool
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 :: (Char -> Bool) -> Char -> String
escapeURIChar Char -> Bool
p Char
c
    | Char -> Bool
p Char
c       = [Char
c]
    | Bool
otherwise = Char
'%' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> ShowS
myShowHex (Char -> Int
ord Char
c) String
""
    where
        myShowHex :: Int -> ShowS
        myShowHex :: Int -> ShowS
myShowHex Int
n String
r =  case Int -> (Int -> Char) -> Int -> ShowS
forall a. (Integral a, Show a) => a -> (Int -> Char) -> a -> ShowS
showIntAtBase Int
16 Int -> Char
forall a. Integral a => a -> Char
toChrHex Int
n String
r of
            []  -> String
"00"
            [Char
a] -> [Char
'0',Char
a]
            String
cs  -> String
cs
        toChrHex :: a -> Char
toChrHex a
d
            | a
d a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
10    = Int -> Char
chr (Char -> Int
ord Char
'0' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
d)
            | Bool
otherwise = Int -> Char
chr (Char -> Int
ord Char
'A' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
d a -> a -> a
forall a. Num a => a -> a -> a
- a
10))


escapeURIString :: (Char -> Bool) -> String -> String
escapeURIString :: (Char -> Bool) -> ShowS
escapeURIString = (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Char -> String) -> ShowS)
-> ((Char -> Bool) -> Char -> String) -> (Char -> Bool) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Char -> String
escapeURIChar


isUnreserved :: Char -> Bool
isUnreserved :: Char -> Bool
isUnreserved Char
c = Char -> Bool
isAlphaNumChar Char
c Bool -> Bool -> Bool
|| (Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"-_.~")


isAlphaChar, isDigitChar, isAlphaNumChar :: Char -> Bool
isAlphaChar :: Char -> Bool
isAlphaChar Char
c    = (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z') Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z')
isDigitChar :: Char -> Bool
isDigitChar Char
c    = Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9'
isAlphaNumChar :: Char -> Bool
isAlphaNumChar Char
c = Char -> Bool
isAlphaChar Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigitChar Char
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 :: String -> String -> IO ()
writeUtf8File String
filepath String
contents = String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
filepath IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
    Handle -> String -> IO ()
hPutStr Handle
h String
contents

withTempDir :: (ExceptionMonad m) => FilePath -> m a -> m a
withTempDir :: String -> m a -> m a
withTempDir String
dir = m () -> m () -> m a -> m a
forall (m :: * -> *) a b c.
ExceptionMonad m =>
m a -> m b -> m c -> m c
gbracket_ (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
createDirectory String
dir)
                            (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectoryRecursive String
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 :: IORef (Map Module String)
html_xrefs_ref = IO (IORef (Map Module String)) -> IORef (Map Module String)
forall a. IO a -> a
unsafePerformIO (Map Module String -> IO (IORef (Map Module String))
forall a. a -> IO (IORef a)
newIORef (String -> Map Module String
forall a. HasCallStack => String -> a
error String
"module_map"))


{-# NOINLINE html_xrefs_ref' #-}
html_xrefs_ref' :: IORef (Map ModuleName FilePath)
html_xrefs_ref' :: IORef (Map ModuleName String)
html_xrefs_ref' = IO (IORef (Map ModuleName String)) -> IORef (Map ModuleName String)
forall a. IO a -> a
unsafePerformIO (Map ModuleName String -> IO (IORef (Map ModuleName String))
forall a. a -> IO (IORef a)
newIORef (String -> Map ModuleName String
forall a. HasCallStack => String -> a
error String
"module_map"))


{-# NOINLINE html_xrefs #-}
html_xrefs :: Map Module FilePath
html_xrefs :: Map Module String
html_xrefs = IO (Map Module String) -> Map Module String
forall a. IO a -> a
unsafePerformIO (IORef (Map Module String) -> IO (Map Module String)
forall a. IORef a -> IO a
readIORef IORef (Map Module String)
html_xrefs_ref)


{-# NOINLINE html_xrefs' #-}
html_xrefs' :: Map ModuleName FilePath
html_xrefs' :: Map ModuleName String
html_xrefs' = IO (Map ModuleName String) -> Map ModuleName String
forall a. IO a -> a
unsafePerformIO (IORef (Map ModuleName String) -> IO (Map ModuleName String)
forall a. IORef a -> IO a
readIORef IORef (Map ModuleName String)
html_xrefs_ref')


-----------------------------------------------------------------------------
-- * List utils
-----------------------------------------------------------------------------


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


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

-----------------------------------------------------------------------------
-- * System tools
-----------------------------------------------------------------------------


#ifdef mingw32_HOST_OS
foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
#else
getProcessID :: IO Int
getProcessID :: IO Int
getProcessID = (CPid -> Int) -> IO CPid -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CPid -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral IO CPid
System.Posix.Internals.c_getpid
#endif