{-# 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
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as LText

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

-- * 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 -> [Char]
(Int -> Verbosity -> ShowS)
-> (Verbosity -> [Char])
-> ([Verbosity] -> ShowS)
-> Show Verbosity
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Verbosity -> ShowS
showsPrec :: Int -> Verbosity -> ShowS
$cshow :: Verbosity -> [Char]
show :: Verbosity -> [Char]
$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 :: [Char] -> Either [Char] Verbosity
parseVerbosity [Char]
"0" = Verbosity -> Either [Char] Verbosity
forall a b. b -> Either a b
Right Verbosity
Silent
parseVerbosity [Char]
"1" = Verbosity -> Either [Char] Verbosity
forall a b. b -> Either a b
Right Verbosity
Normal
parseVerbosity [Char]
"2" = Verbosity -> Either [Char] Verbosity
forall a b. b -> Either a b
Right Verbosity
Verbose
parseVerbosity [Char]
"3" = Verbosity -> Either [Char] Verbosity
forall a b. b -> Either a b
Right Verbosity
Deafening
parseVerbosity [Char]
"silent" = Verbosity -> Either [Char] Verbosity
forall a. a -> Either [Char] a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Verbosity
Silent
parseVerbosity [Char]
"normal" = Verbosity -> Either [Char] Verbosity
forall a. a -> Either [Char] a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Verbosity
Normal
parseVerbosity [Char]
"verbose" = Verbosity -> Either [Char] Verbosity
forall a. a -> Either [Char] a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Verbosity
Verbose
parseVerbosity [Char]
"debug" = Verbosity -> Either [Char] Verbosity
forall a. a -> Either [Char] a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Verbosity
Deafening
parseVerbosity [Char]
"deafening" = Verbosity -> Either [Char] Verbosity
forall a. a -> Either [Char] a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Verbosity
Deafening
parseVerbosity [Char]
other = [Char] -> Either [Char] Verbosity
forall a b. a -> Either a b
Left ([Char]
"Can't parse verbosity " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
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 -> [Char] -> m ()
out Verbosity
progVerbosity Verbosity
msgVerbosity [Char]
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
$ [Char] -> IO ()
putStrLn [Char]
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 -> [Char]
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 -> [Char]) -> ModuleName -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [Char]
moduleNameString

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

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

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

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

moduleNameUrl :: Module -> OccName -> Text
moduleNameUrl :: GenModule Unit -> OccName -> Text
moduleNameUrl GenModule Unit
mdl OccName
n = GenModule Unit -> Text
moduleUrl GenModule Unit
mdl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> OccName -> Text
nameAnchorId OccName
n

moduleNameUrl' :: ModuleName -> OccName -> Text
moduleNameUrl' :: ModuleName -> OccName -> Text
moduleNameUrl' ModuleName
mdl OccName
n = [Char] -> Text
LText.pack (ModuleName -> [Char]
moduleHtmlFile' ModuleName
mdl) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> OccName -> Text
nameAnchorId OccName
n

nameAnchorId :: OccName -> Text
nameAnchorId :: OccName -> Text
nameAnchorId OccName
name = Text -> Text
makeAnchorId (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
LText.pack (OccName -> [Char]
occNameString OccName
name))
  where
    prefix :: Text
prefix
      | OccName -> Bool
isValOcc OccName
name = Text
"v"
      | Bool
otherwise = Text
"t"

-- | Takes an arbitrary string and makes it a valid anchor ID. The mapping is
-- identity preserving.
makeAnchorId :: Text -> Text
makeAnchorId :: Text -> Text
makeAnchorId Text
input =
    case Text -> Maybe (Char, Text)
LText.uncons Text
input of
        Maybe (Char, Text)
Nothing        -> Text
LText.empty
        Just (Char
f, Text
rest) ->
            (Char -> Bool) -> Char -> Text
escape Char -> Bool
isAlpha Char
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Char -> Text) -> Text -> Text
LText.concatMap ((Char -> Bool) -> Char -> Text
escape Char -> Bool
isLegal) Text
rest
  where
    escape :: (Char -> Bool) -> Char -> Text
    escape :: (Char -> Bool) -> Char -> Text
escape Char -> Bool
p Char
c
        | Char -> Bool
p Char
c       = Char -> Text
LText.singleton Char
c
        | Bool
otherwise =
            -- "-" <> show (ord c) <> "-"
            Char -> Text -> Text
LText.cons Char
'-' ([Char] -> Text
LText.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show (Char -> Int
ord Char
c) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"-"))

    isLegal :: Char -> Bool
    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 :: [Char]
haddockJsFile = [Char]
"haddock-bundle.min.js"

jsQuickJumpFile :: String
jsQuickJumpFile :: [Char]
jsQuickJumpFile = [Char]
"quick-jump.min.js"

quickJumpCssFile :: String
quickJumpCssFile :: [Char]
quickJumpCssFile = [Char]
"quick-jump.css"

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

-- * Misc.

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

getProgramName :: IO String
getProgramName :: IO [Char]
getProgramName = ShowS -> IO [Char] -> IO [Char]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char] -> ShowS
forall {a}. Eq a => [a] -> [a] -> [a]
`withoutSuffix` [Char]
".bin") IO [Char]
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. [Char] -> IO a
bye [Char]
s = [Char] -> IO ()
putStr [Char]
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 -> [Char]
escapeURIChar Char -> Bool
p Char
c
  | Char -> Bool
p Char
c = [Char
c]
  | Bool
otherwise = Char
'%' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> ShowS
myShowHex (Char -> Int
ord Char
c) [Char]
""
  where
    myShowHex :: Int -> ShowS
    myShowHex :: Int -> ShowS
myShowHex Int
n [Char]
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 [Char]
r of
      [] -> [Char]
"00"
      [Char
a] -> [Char
'0', Char
a]
      [Char]
cs -> [Char]
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 -> [Char]) -> ShowS
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap ((Char -> [Char]) -> ShowS)
-> ((Char -> Bool) -> Char -> [Char]) -> (Char -> Bool) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Char -> [Char]
escapeURIChar

isUnreserved :: Char -> Bool
isUnreserved :: Char -> Bool
isUnreserved Char
c = Char -> Bool
isAlphaNumChar Char
c Bool -> Bool -> Bool
|| (Char
c Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` ([Char]
"-_.~" :: 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 :: [Char] -> [Char] -> IO ()
writeUtf8File [Char]
filepath [Char]
contents = [Char] -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
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 -> [Char] -> IO ()
hPutStr Handle
h [Char]
contents

withTempDir :: (MonadIO m, MonadMask m) => FilePath -> m a -> m a
withTempDir :: forall (m :: Type -> Type) a.
(MonadIO m, MonadMask m) =>
[Char] -> m a -> m a
withTempDir [Char]
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
$ [Char] -> IO ()
createDirectory [Char]
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
$ [Char] -> IO ()
removeDirectoryRecursive [Char]
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 (GenModule Unit) [Char])
html_xrefs_ref = IO (IORef (Map (GenModule Unit) [Char]))
-> IORef (Map (GenModule Unit) [Char])
forall a. IO a -> a
unsafePerformIO (Map (GenModule Unit) [Char]
-> IO (IORef (Map (GenModule Unit) [Char]))
forall a. a -> IO (IORef a)
newIORef ([Char] -> Map (GenModule Unit) [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"module_map"))

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

{-# NOINLINE html_xrefs #-}
html_xrefs :: Map Module FilePath
html_xrefs :: Map (GenModule Unit) [Char]
html_xrefs = IO (Map (GenModule Unit) [Char]) -> Map (GenModule Unit) [Char]
forall a. IO a -> a
unsafePerformIO (IORef (Map (GenModule Unit) [Char])
-> IO (Map (GenModule Unit) [Char])
forall a. IORef a -> IO a
readIORef IORef (Map (GenModule Unit) [Char])
html_xrefs_ref)

{-# NOINLINE html_xrefs' #-}
html_xrefs' :: Map ModuleName FilePath
html_xrefs' :: Map ModuleName [Char]
html_xrefs' = IO (Map ModuleName [Char]) -> Map ModuleName [Char]
forall a. IO a -> a
unsafePerformIO (IORef (Map ModuleName [Char]) -> IO (Map ModuleName [Char])
forall a. IORef a -> IO a
readIORef IORef (Map ModuleName [Char])
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)