{-# 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 (Verbosity -> Verbosity -> Bool
(Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool) -> Eq Verbosity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
/= :: 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
$ccompare :: Verbosity -> Verbosity -> Ordering
compare :: Verbosity -> Verbosity -> Ordering
$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
>= :: Verbosity -> Verbosity -> Bool
$cmax :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
min :: Verbosity -> Verbosity -> 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
$csucc :: Verbosity -> Verbosity
succ :: Verbosity -> Verbosity
$cpred :: Verbosity -> Verbosity
pred :: Verbosity -> Verbosity
$ctoEnum :: Int -> Verbosity
toEnum :: Int -> Verbosity
$cfromEnum :: Verbosity -> Int
fromEnum :: Verbosity -> Int
$cenumFrom :: Verbosity -> [Verbosity]
enumFrom :: Verbosity -> [Verbosity]
$cenumFromThen :: Verbosity -> Verbosity -> [Verbosity]
enumFromThen :: Verbosity -> Verbosity -> [Verbosity]
$cenumFromTo :: Verbosity -> Verbosity -> [Verbosity]
enumFromTo :: Verbosity -> Verbosity -> [Verbosity]
$cenumFromThenTo :: Verbosity -> Verbosity -> Verbosity -> [Verbosity]
enumFromThenTo :: Verbosity -> Verbosity -> Verbosity -> [Verbosity]
Enum, Verbosity
Verbosity -> Verbosity -> Bounded Verbosity
forall a. a -> a -> Bounded a
$cminBound :: Verbosity
minBound :: Verbosity
$cmaxBound :: Verbosity
maxBound :: 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
$cshowsPrec :: Int -> Verbosity -> ShowS
showsPrec :: Int -> Verbosity -> ShowS
$cshow :: Verbosity -> String
show :: Verbosity -> String
$cshowList :: [Verbosity] -> ShowS
showList :: [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
Verbose
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 a. a -> Either String a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Verbosity
Silent
parseVerbosity String
"normal" = Verbosity -> Either String Verbosity
forall a. a -> Either String a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Verbosity
Normal
parseVerbosity String
"verbose" = Verbosity -> Either String Verbosity
forall a. a -> Either String a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Verbosity
Verbose
parseVerbosity String
"debug" = Verbosity -> Either String Verbosity
forall a. a -> Either String a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Verbosity
Deafening
parseVerbosity String
"deafening" = Verbosity -> Either String Verbosity
forall a. a -> Either String a
forall (m :: Type -> Type) 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 :: forall (m :: Type -> Type).
MonadIO m =>
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 a. IO a -> m a
forall (m :: Type -> Type) 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 a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

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

-- * Some Utilities

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

mkMeta :: Doc a -> MDoc a
mkMeta :: forall a. Doc a -> MDoc a
mkMeta Doc a
x = MetaDoc (ZonkAny 1) (ZonkAny 0)
forall mod id. MetaDoc mod id
emptyMetaDoc{_doc = 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
forall unit. GenModule unit -> 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 :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isAlpha String
ls = String
ls
      | Bool
otherwise = (Char -> String) -> ShowS
forall (t :: Type -> Type) 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 :: Type -> Type) 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 a b. (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) 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 a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [a]
str Int -> Int -> Int
forall a. Num a => a -> a -> a
- [a] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [a]
suff) [a]
str
      | Bool
otherwise = [a]
str

bye :: String -> IO a
bye :: forall a. String -> IO a
bye String
s = String -> IO ()
putStr String
s IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: Type -> Type) 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 => 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 :: Type -> Type) 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 a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) 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 :: (MonadIO m, MonadMask m) => FilePath -> m a -> m a
withTempDir :: forall (m :: Type -> Type) a.
(MonadIO m, MonadMask m) =>
String -> m a -> m a
withTempDir String
dir =
  m () -> m () -> m a -> m a
forall (m :: Type -> Type) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_
    (IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) 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 a. IO a -> m a
forall (m :: Type -> Type) 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 :: forall a. Eq a => 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 :: forall a b. (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
b b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
bs, [a]
cs)
  | Bool
otherwise = ([], [a]
xs)